home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
BBS Toolkit
/
BBS Toolkit.iso
/
rbbs_pc
/
mpl172b.zip
/
RBBSSUB5.BAS
< prev
next >
Wrap
BASIC Source File
|
1989-09-11
|
95KB
|
2,614 lines
' $linesize:132
' $title: 'RBBSSUB5.BAS CPC17.2B, Copyright 1986 - 89 by D. Thomas Mack'
' Copyright 1989 by D. Thomas Mack, all rights reserved.
' Name ...............: RBBSSUB5.BAS
' Written by .........: D. Thomas Mack
' First Released .....: May 28, 1989
' Subsequent Releases.: 07-30-89
' Copyright ..........: 1986 - 1989
' Purpose.............: The Remote Bulletin Board System for the IBM PC,
' RBBS-PC.BAS utilizes a lot of common subroutines. Those that do not
' require error trapping are incorporated within RBBSSUB 2-5 as
' separately callable subroutines in order to free up as much
' code as possible within the 64K code segment used by RBBS-PC.BAS.
' Parameters..........: Most parameters are passed via a COMMON statement.
'
' Subroutine Line Function of Subroutine
' Name Number
' BRKFNAME 63300 Break file name into component parts
' BUFASUNIT 63500 Buffer out a string with CR's
' CALLOPT 63470 Set prompts based on the user's security
' DOORRTN 63100 Process door requests
' FILESYS 20117 File System for RBBS-PC
' FINDIT Check whether file exists and if so open as #2
' FORMREAD 63420 Read from file into a form
' LOCKAPPND 63400 Prepare for a file append
' MACROEXE 63460 Execute internal macro rather than user
' NOPATH 63480 Detects whether string has a path in it
' RESTORECOM 63310 Restore comm port after external program
' READMACRO 63330 Read and process macro
' SHELLEXIT 63320 Exit RBBS via shell
' UNLKAPPND 63410 Clean up after file append
' WILDCARD 63200 Match string to a pattern
'
' $INCLUDE: 'RBBS-VAR.BAS'
'
20117 ' $SUBTITLE: 'FILESYS -- subroutine for RBBS-PC's file system'
' $PAGE
'
' NAME -- FILESYS
'
' INPUTS -- PARAMETER MEANING
' FILESYS.PARAMETER = 1 LIST THE SYSOP'S COMMENTS FILE
' 2 L)IST DIRECTORY COMMAND
' 3 D)OWNLOAD COMMAND
' 4 RETURN FROM EXTERNAL PROTOCOLS
' 5 U)PLOAD COMMAND
' 6 S)CAN DIRECTORY COMMAND
' 7 P)ERSONAL FILES COMMAND
' 8 N)EW FILES COMMAND
' 9 RETURN FROM EXTENDED DESCRIPTION
'
' OUTPUTS -- FILESYS.PARAMETER = 1 COMMAND PROCESSED SUCCESSFULLY
' 2 RECYCLE TO TOP OF RBBS-PC (202)
' 3 PROCESS NEXT COMMAND (1200)
' 4 DENY USER ACCESS (1380)
' 5 HANDLE EXTENDED DESCRIP. (2008)
' 6 USER'S TIME EXCEEDED (10553)
' 7 CARRIER DROPPED (10595)
'
' PURPOSE -- To handle the RBBS-PC file system commands
'
SUB FILESYS STATIC
FF = FILESYS.PARAMETER
FILESYS.PARAMETER = 1
ON FF GOSUB 20119, _ ' HANDLER TO LIST COMMENTS TO SYSOP
20150, _ ' L)IST DIRECTORY COMMAND HANDLER
20180, _ ' D)OWNLOAD COMMAND HANDLER
20262, _ ' RETURN FROM EXTERNAL PROTOCOL'S
20400, _ ' U)PLOAD COMMAND HANDLER
21800, _ ' S)CAN DIRECTORY COMMAND HANDLER
21850, _ ' P)ERSONAL FILES COMMAND HANDLER
21860, _ ' N)EW FILES COMMAND HANDLER
20705 ' RETURN FROM EXTENDED DESCRIPTIONS
GOTO 21920
20119 EC = 0
GOTO 20122
'
' ***** SCAN DIRECTORIES (PRINT TEXT) ****
'
' (formerly lines 7000 to 7260 in RBBS-PC.BAS CPC16-1A
20120 A$ = CX$(2)+"Scanning"+CX$(3)+" Directory "+CX$(5) + _
FILE.NAME.HOLD$ +CX$(3)+ _
" for " +CX$(7)+ _
RS$
GOSUB 21650
IF FILESYS.PARAMETER > 1 THEN _
RETURN
PG = TRUE
20122 CALL OPENWORK (2,FILE.NAME$)
IF EC = 53 THEN _
CALL UPDTCALR ("Missing File " + FILE.NAME$,2) : _
A$ = "Missing file " + _
FILE.NAME$ + _
". Please tell SYSOP" : _
GOSUB 21650 : _
RETURN
20124 CALL CARRIER
IF EOF(2) OR _
(SUBROUTINE.PARAMETER = -1 AND NOT LOCAL.USER) THEN _
GOTO 20142
20126 CALL READDIR (2,1)
IF EC <> 0 THEN _
EL = 20126 : _
GOTO 21900
IF CK = 0 THEN _
GOTO 20140
IF LEN(A$) > 0 THEN IF ASC(A$) = 32 THEN _
IF LAST.OK AND NOT EXTENDED.OFF THEN _
GOTO 20140 _
ELSE GOTO 20124
LAST.OK = FALSE
20128 IF CK > 1 THEN _
IF WILD.SEARCH THEN _
A = INSTR(A$," ") : _
IF A = 0 THEN _
GOTO 20124 _
ELSE Z$ = LEFT$(A$,A - 1) : _
CALL WILDFILE (RS$,Z$,XXX) : _
GOTO 20136_
ELSE Z$ = A$ : _
CALL ALLCAPS (Z$) : _
XXX = (INSTR(Z$,RS$) = 0) : _
GOTO 20136
20130 A = INSTR(9,MID$(A$,1,32),"/")
IF A = 0 THEN _
A = INSTR(9,MID$(A$,1,32),"-")
20132 IF A < 3 THEN _
GOTO 20124
IF INSTR("0123456789",MID$(A$,A - 1,1)) = 0 THEN _
GOTO 20124
A = A - 2
WK$ = RIGHT$(MID$(A$,A,8),2) + _
LEFT$(MID$(A$,A,8),2) + _
MID$(MID$(A$,A,8),4,2)
IF MID$(WK$,3,1) = " " THEN _
MID$(WK$,3,1) = "0"
IF MID$(WK$,5,1) = " " THEN _
MID$(WK$,5,1) = "0"
20134 XXX = (WK$ < RS$)
20136 IF XXX THEN _
GOTO 20124
IF PG THEN _
PG = FALSE : _
CALL OPENWORK (2,FILE.NAME$) : _
Q = 0 : _
GOTO 20124
20138 IF PG THEN _
GOTO 20124
20140 LAST.OK = TRUE
GOSUB 21650
IF FILESYS.PARAMETER > 1 THEN _
RETURN
CALL ASKMORE ("",TRUE,TRUE,ANS.INDEX,FALSE) ' KG081201
IF NO THEN _
EC = 0 : _
RETURN
IF NOT RET THEN _
GOTO 20124
20142 Q = 0
CLOSE 2
CALL CARRIER
IF SUBROUTINE.PARAMETER = -1 THEN _
FILESYS.PARAMETER = 7
RETURN
'
' * L - COMMAND FROM FILES MENU (LIST DIRECTORY)
'
20150 LIST.DIRECTORY = TRUE
LIST.NEW = FALSE
SEARCH.DATE$ = ""
SEARCH.STRING$ = ""
SHOW.DIR.OF.DIR = NOT EXPERT.USER
CK = 0
IF Q > 1 THEN _
CALL ALLCAPS (B$(2)) : _
IF B$(2) = "L" THEN _
SHOW.DIR.OF.DIR = TRUE ' KG081201
SEARCHING.ALL = FALSE ' KG081201
20155 IF DOWNLOAD.COMPLETED AND AUTO.END = 1 THEN _
FILESYS.PARAMETER = 7: _
RETURN
IF LIST.NEW OR ANS.INDEX > 255 THEN _ ' KG081201
RETURN ' KG081201
CALL GETDIRS (SHOW.DIR.OF.DIR)
IF Q = 0 THEN _
RETURN
SHOW.DIR.OF.DIR = FALSE
CALL CONVDIRS (ANS.INDEX) ' KG081201
QX = LAST.INDEX ' KG081201
20157 CALL CARRIER ' KG081201
IF SUBROUTINE.PARAMETER = -1 THEN _
FILESYS.PARAMETER = 7 : _
RETURN ' KG081201
GOTO 20161 ' KG081201
20159 IF ANS.INDEX < LAST.INDEX THEN _ ' KG081201
GOTO 20155 ' KG081201
SEARCHING.ALL = FALSE ' KG081201
CALL CSPUSHPOP (1) ' KG082702
LAST.INDEX = 0 ' KG082702
IF NO OR (FILE.NAME.HOLD$ = DIRECTORY.PREFIX$) THEN _
GOTO 20155 ' KG081201
CALL QTPUT (EMPHASIZE.OFF$,0)
A$ = "End list. R)elist, [Q]uit, or download what"
GOSUB 21668
CALL ALLCAPS (B$(1))
IF B$(1) = "R" THEN _
B$(ANS.INDEX) = A1$ : _ ' KG081201
GOTO 20161
IF LEN(B$(1)) > 1 AND _
USER.SECURITY.LEVEL >= OPT.SEC(19 - 20 * (MENU.INDEX = 6)) THEN _
ANS.INDEX = 1 : _ ' KG081201
GOSUB 20202 ' KG082702
CALL CSPUSHPOP (2) ' KG082702
RETURN ' KG082702
20161 IF INSTR(B$(ANS.INDEX),".") THEN _ ' KG081201
GOTO 20172
VIOLATION$ = "List Dir. "
Z$ = B$(ANS.INDEX) ' KG081201
A = INSTR("E+E-E",Z$)
IF A > 0 THEN _
IF A = 5 THEN _
EXTENDED.OFF = NOT EXTENDED.OFF : _
GOTO 20155 _ ' KG081201
ELSE EXTENDED.OFF = (A > 2) : _
GOTO 20155 ' KG081201
CALL ALLCAPS(Z$)
FILE.NAME.HOLD$ = Z$
A1$ = Z$
IF Z$ = DIRECTORY.PREFIX$ THEN _
GOTO 20164
IN.FMS = FALSE
20162 CALL CSPUSHPOP (1) ' save dir list list processing ' KG082702
CALL FMS (Z$,SEARCH.STRING$,SEARCH.DATE$,IN.FMS, _
CATEGORY.NAME$(),CATEGORY.CODE$(),CATEGORY.DESC$(),_
DOWNLOAD.FLAG,CAT.FOUND,ANS.INDEX) ' KG081201
WHILE DOWNLOAD.FLAG > 0 AND SUBROUTINE.PARAMETER > -1 ' KG081201
GOSUB 20202
IF FILESYS.PARAMETER > 1 THEN _
RETURN
IF DOWNLOAD.COMPLETED and AUTO.END = 1 THEN _
RETURN ' AUTOLOGOFF MOD
X$ = CATEGORY.CODE$(CAT.FOUND)
CALL DISUPDIR (X$,SEARCH.STRING$,SEARCH.DATE$,DOWNLOAD.FLAG,ANS.INDEX) ' KG081201
CALL CHKTREMAIN (TIME.REMAINING!)
IF SUBROUTINE.PARAMETER = -1 THEN _
FILESYS.PARAMETER = 6 : _
RETURN
CALL CARRIER
WEND
IF SUBROUTINE.PARAMETER = -1 THEN _
FILESYS.PARAMETER = 7 : _
RETURN
IF ANS.INDEX > 255 THEN _ ' KG081201
LAST.INDEX = 0 : _ ' KG081201
RETURN ' KG081201
CALL CSPUSHPOP (2) ' restore dir list list processing ' KG082702
ACTIVE.FMS.DIRECTORY$ = ""
IF IN.FMS THEN _
GOTO 20159 ' KG081201
IF USER.SECURITY.LEVEL < MIN.SEC.TO.VIEW THEN _
IF FILE.NAME.HOLD$ = UPLOAD.DIR.CHECK$ THEN _
FILE.NAME.HOLD$ = "of uploads" : _
GOTO 20172
FILE.NAME.HOLD$ = B$(ANS.INDEX) ' KG081201
IF LIMIT.SEARCH.TO.FMS THEN _
GOTO 20166
IF NOT SEARCHING.ALL THEN _ ' KG081201
IF FILE.NAME.HOLD$ = "ALL" OR FILE.NAME.HOLD$ = "A" THEN _ ' KG081201
SEARCHING.ALL = TRUE : _ ' KG083002
GOTO 21890 ' KG081201
CALL BADFILE (FILE.NAME.HOLD$,BAD.FILE.NAME.INDEX)
ON BAD.FILE.NAME.INDEX GOTO 20163,20172,20176
20163 FILE.NAME$ = FILE.NAME.HOLD$
CALL BADNAME (BAD.FILE.NAME.INDEX)
ON BAD.FILE.NAME.INDEX GOTO 20164,20176
20164 IF FILE.NAME$ = UPLOAD.DIR.CHECK$ AND _
USER.SECURITY.LEVEL >= MIN.SEC.TO.VIEW THEN _
FILE.NAME$ = UPLOAD.PATH$ _
ELSE FILE.NAME$ = DIRECTORY.PATH$
FILE.NAME$ = FILE.NAME$ + _
FILE.NAME.HOLD$ + _
"." + _
DIRECTORY.EXTENTION$
CALL GRAPHIC (USER.GRAPHIC.DEFAULT$,FILE.NAME$)
20165 IF OK THEN _
CALL READDIR (2,1) : _
IF EC = 0 THEN _
IF LEFT$(A$,4) = "\FMS" THEN _
IN.FMS = TRUE : _
ACTIVE.FMS.DIRECTORY$ = FILE.NAME$ : _
GOTO 20162 _
ELSE GOTO 20167
20166 FILE.NAME$ = DIRECTORY.PATH$ + _
FILE.NAME.HOLD$ + ".MNU"
CALL FINDIT (FILE.NAME$)
IF OK THEN _
CALL BUFFILE (FILE.NAME$,ANS.INDEX) : _ ' KG081201
GOTO 20155 ' KG081201
IF ALTDIR.EXTENSION$ = "" THEN _
GOTO 20172
FILE.NAME$ = DIRECTORY.PATH$ + _
FILE.NAME.HOLD$ + _
"." + _
ALTDIR.EXTENSION$
CALL GRAPHIC (USER.GRAPHIC.DEFAULT$,FILE.NAME$)
IF NOT OK THEN _
GOTO 20172
20167 B$(0) = B$(ANS.INDEX) ' KG081201
IF NOT LIST.NEW THEN _
GOTO 20168
GOSUB 20120
IF FILESYS.PARAMETER > 1 THEN _
RETURN
GOTO 20170
20168 CALL BUFFILE(FILE.NAME$,ANS.INDEX) ' KG081201
CALL CARRIER
IF SUBROUTINE.PARAMETER = -1 THEN _
FILESYS.PARAMETER = 7 : _
RETURN
20170 IF ANS.INDEX > 255 THEN _ ' KG081201
LAST.INDEX = 0 : _ ' KG081201
RETURN ' KG081201
B$(ANS.INDEX) = B$(0) ' KG081201
GOTO 20159 ' KG081201
20172 IF NOT SEARCHING.ALL THEN _
A$ = "Directory " + _
FILE.NAME.HOLD$ + _
" not found!" : _
GOSUB 21640 : _
NO = TRUE : _
IF FILESYS.PARAMETER > 1 THEN _
RETURN
GOTO 20155 ' KG081201
20176 CALL SVIOLATION
IF DENY.ACCESS THEN _
FILESYS.PARAMETER = 4 : _
RETURN
GOTO 20172
'
' * D - COMMAND FROM FILES MENU (SEARCH FOR FILE TO DOWNLOAD)
'
20180 A$ = CX$(5)+"Download"+CX$(6)+" what file(s)"+CX$(7)
GOSUB 21668 ' KG081201
IF FILESYS.PARAMETER > 1 THEN _
RETURN
IF Q = 0 THEN _
RETURN
20202 IF (TIME.LOCK AND 2) AND (NOT TIME.LOCK.EXEMPT) AND NOT HAS.PRIVDOOR THEN _ ' KG052501
CALL TIMELOCK : _
IF NOT OK THEN _
RETURN
LAST.DOWNLOAD = LAST.INDEX ' KG081201
FIRST.DOWNLOAD = ANS.INDEX ' KG081201
COMMAND.TRANSFER$ = ""
IF AUTODOWNLOAD.AVAILABLE THEN _
COMMAND.TRANSFER$ = "X"
AUTODOWNLOAD.IN.PROGRESS = AUTODOWNLOAD.AVAILABLE
IF LAST.DOWNLOAD > FIRST.DOWNLOAD THEN _
Z$ = B$(LAST.DOWNLOAD) : _
CALL ALLCAPS(Z$) : _
IF LEN (Z$) = 1 AND INSTR(DFLTXFER$,Z$) > 0 THEN _
LAST.DOWNLOAD = LAST.DOWNLOAD - 1 : _
COMMAND.TRANSFER$ = Z$ : _
AUTODOWNLOAD.IN.PROGRESS = FALSE : _
IF MID$(INTERNAL.EQUIV$,INSTR(DFLTXFER$,Z$),1) = "N" THEN _
COMMAND.TRANSFER$ = ""
BATCH.BYTES# = 0
BATCH.BLOCKS# = 0
CALL KILLWORK (NODE.WORK.FILE$)
EC = 0
FOR ANS.INDEX = FIRST.DOWNLOAD TO LAST.DOWNLOAD ' KG081201
GOSUB 20205
COMMAND.TRANSFER$ = FT$ ' KG082301
CALL LINE25 ' KG082703
IF FILESYS.PARAMETER > 1 THEN _
ANS.INDEX = LAST.DOWNLOAD + 1 ' KG081201
20203 NEXT
LAST.INDEX = 0 ' KG082702
IF FILESYS.PARAMETER > 1 THEN _
RETURN
BATCH.TRANSFER = FALSE
COMMAND.TRANSFER$ = ""
RETURN
20205 MARK.TIME = (ANS.INDEX = FIRST.DOWNLOAD OR NOT CONCAT.FILES) ' KG081201
FILE.NAME$ = B$(ANS.INDEX) ' KG081201
VIOLATION$ = "Download "
IF PERSONAL.DOWNLOAD THEN _
CALL BRKFNAME (FILE.NAME$,DR$,Y$,X$,TRUE) : _
FILE.NAME.HOLD$ = Y$ + _
X$ : _
GOTO 20235
FILE.NAME.HOLD$ = FILE.NAME$
CALL BADFILE (FILE.NAME$,BAD.FILE.NAME.INDEX)
ON BAD.FILE.NAME.INDEX GOTO 20220,20231,20233
20220 CALL ROTORSDIR (FILE.NAME$,SUBDIR$(),SUBDIR.COUNT + _
((USER.SECURITY.LEVEL < MIN.SEC.TO.VIEW) OR _
NOT CAN.DOWNLOAD.FROM.UP),MARK.TIME)
20225 IF OK THEN _
GOTO 20235
20231 A$ = FILE.NAME.HOLD$ + _
" not found!"
CALL UPDTCALR (A$,2)
AUTO.LOGOFF = FALSE
IF AUTODOWNLOAD.IN.PROGRESS THEN _
A$ = A$ + _
" during AUTODOWNLOAD" : _
GOSUB 21640 : _
RETURN
A$ = A$ + _
" Correct name"+PRESS.ENTER.EXPERT$
GOSUB 21660
IF FILESYS.PARAMETER > 1 THEN _
RETURN
IF Q=0 THEN _
RETURN
B$(ANS.INDEX) = B$(1) ' KG081201
GOTO 20205
20233 CALL SVIOLATION
IF DENY.ACCESS THEN _
FILESYS.PARAMETER = 4 : _
RETURN
GOTO 20231
20235 CALL BADNAME (BAD.FILE.NAME.INDEX)
ON BAD.FILE.NAME.INDEX GOTO 20236,20245
20236 LINE.25$ = "(D) " + _
Z$
IF AUTODOWNLOAD.IN.PROGRESS THEN _
MID$(LINE.25$,2,1) = "A"
'
' * TEST FOR DOWNLOAD SECURITY
'
CALL OPENWORK (2,FILESEC.FILE$)
IF EC = 53 THEN _
CALL UPDTCALR ("Missing file " + FILESEC.FILE$,2) : _
GOTO 20247
20242 IF EOF(2) THEN _
GOTO 20247
CALL READPARMS (WORK.ARA$(),3,1)
IF EC <> 0 THEN _
EL = 20242 : _
GOTO 21900
20243 CALL WILDFILE (WORK.ARA$(1),Z$,OK)
IF NOT OK THEN _
GOTO 20242
20244 IF USER.SECURITY.LEVEL < VAL(WORK.ARA$(2)) THEN _
GOTO 20245
FILE.PASSWORD$ = WORK.ARA$(3)
IF FILE.PASSWORD$ = "" THEN _
GOTO 20247
CALL ALLCAPS (FILE.PASSWORD$)
IF FILE.PASSWORD$ = PASSWORD$ THEN _
GOTO 20247
A$ = "Enter PASSWORD to download " + _
FILE.NAME$
GOSUB 21660
IF FILESYS.PARAMETER > 1 THEN _
RETURN
IF Q = 0 THEN _
RETURN
CALL ALLCAPS (B$(1))
IF B$(1) = FILE.PASSWORD$ THEN _
GOTO 20247
20245 VIOLATION$ = "DownLoad " + _
FILE.NAME$
20246 CALL SVIOLATION
IF DENY.ACCESS THEN _
FILESYS.PARAMETER = 4
RETURN
20247 DF = 0
CALL BRKFNAME (FILE.NAME$,DR$,X$,EXTENTION$,FALSE)
IF AUTODOWNLOAD.IN.PROGRESS THEN _
A$ = "Transferring -- " + _
B$(ANS.INDEX) : _ ' KG081201
GOSUB 21640 : _
IF FILESYS.PARAMETER > 1 THEN _
RETURN
IF INSTR("...WRK.FW .ARC.EXE.COM.OBJ.WKS.LBR.ZIP.PAK.ZOO.LZH.","."+EXTENTION$+".") > 2 OR _ ' KG081601
MID$(EXTENTION$,2,1) = "Q" OR _
(REQUIRE.NON.ASCII AND EXTENTION$ = "BAS") THEN _
DF = TRUE ' KG081201
20248 A$ = ""
IF BATCH.TRANSFER THEN _
IF ANS.INDEX < LAST.DOWNLOAD THEN _ ' KG081201
GOTO 20260
CALL XFERTYPE (2,TRUE)
IF FF THEN _
GOTO 20260
CALL XFERTYPE (1,TRUE)
IF SUBROUTINE.PARAMETER = -1 THEN _
FILESYS.PARAMETER = 7 : _ ' KG081201
RETURN
20260 TRANSFER.FUNCTION = 1
GOSUB 21790
IF FILESYS.PARAMETER > 1 THEN _
RETURN
BATCH.TRANSFER = BATCH.PROTO 'Pe Batch Mod
' BATCH.TRANSFER = (BATCH.PROTO AND (LAST.DOWNLOAD > FIRST.DOWNLOAD))
IF BATCH.TRANSFER AND COMMAND.TRANSFER$ = "" THEN _
COMMAND.TRANSFER$ = FT$
ON INSTR("AXCYN",INTERNAL.PROTO$) GOTO _
20340, _ ' ASCII DOWNLOAD
20290, _ ' XMODEM
20290, _ ' XMODEM CRC
20270, _ ' YMODEM
21700 ' NONE - CANCEL
'
' * EXTERNAL PROTOCOL DOWNLOADS/UPLOADS
'
20261 IF REQ.8.BIT THEN _
IF NOT EIGHT.BIT THEN _
GOSUB 20318 : _
IF FILESYS.PARAMETER > 1 THEN _
RETURN _
ELSE GOSUB 20992 : _
IF FILESYS.PARAMETER > 1 THEN _
RETURN
IF TRANSFER.FUNCTION = 1 THEN _
GOSUB 20750 : _
CLOSE 2 : _
IF FILESYS.PARAMETER > 1 OR NOT OK THEN _
RETURN
IF BATCH.TRANSFER THEN _
IF ANS.INDEX < LAST.DOWNLOAD THEN _ ' KG081201
RETURN _
ELSE BLOCKS.IN.FILE# = BATCH.BLOCKS# : _
BYTES.IN.FILE# = BATCH.BYTES# : _
NUM.DNLD.BYTS! = BATCH.BYTES# : _
IF BYTES.IN.FILE# < 1 THEN _ ' KG082507
RETURN _ ' KG082507
ELSE GOSUB 20780 : _ ' KG082507
IF FILESYS.PARAMETER > 1 OR NOT OK THEN _ ' KG082507
RETURN ' KG082507
IF AUTODOWNLOAD.IN.PROGRESS THEN _
CALL SENDNAME : _
IF ABORT THEN _
DOWNLOAD.COMPLETED = FALSE : _
GOSUB 21760 : _
RETURN
CALL TRANSFER
20262 IF PRIVATE.DOOR THEN _
COMMAND.TRANSFER$ = FT$ : _
CALL XFERTYPE (2,TRUE) : _
COMMAND.TRANSFER$ = ""
CALL OPENWORK (2,"XFER-" + NODE.ID$ + ".DEF")
IF EC <> 0 THEN _
GOTO 20267
CALL READPARMS (WORK.ARA$(), FAILURE.PARM, 1)
IF EC <> 0 THEN _
GOTO 20267
CALL KILLWORK ("XFER-" + NODE.ID$ + ".DEF")
20264 IF PRIVATE.DOOR THEN _
FILE.NAME$ = WORK.ARA$(1) : _
CALL BRKFNAME (FILE.NAME$,X$,FILE.NAME.HOLD$,Y$,TRUE) : _
FILE.NAME.HOLD$ = FILE.NAME.HOLD$ + _
Y$ : _
SIZE.ONLY = TRUE : _
CALL OPENWORK (2,FILE.NAME$) : _
GOSUB 20760 : _
IF FILESYS.PARAMETER > 1 OR NOT OK THEN _
RETURN
IF LEFT$(WORK.ARA$(FAILURE.PARM),1) = "L" THEN _
MID$(WORK.ARA$(FAILURE.PARM),1,1) = FAILURE.STRING$
20265 IF TRANSFER.FUNCTION = 2 THEN _
IF INSTR(WORK.ARA$(FAILURE.PARM),FAILURE.STRING$) <> 1 THEN _
GOTO 20700 _
ELSE GOTO 20730
IF TRANSFER.FUNCTION = 1 THEN _
DOWNLOAD.COMPLETED = (INSTR(WORK.ARA$(FAILURE.PARM),FAILURE.STRING$) <> 1)
GOSUB 21760
CALL CARRIER
IF SUBROUTINE.PARAMETER = -1 THEN _
FILESYS.PARAMETER = 7
RETURN
'
' * XFER FILE NOT FOUND
'
20267 EL = 20262
GOTO 21900
'
' * YMODEM DOWNLOAD DRIVER
'
20270 GOTO 20292
'
' * XMODEM DOWNLOAD DRIVER
'
20290 '
20292 GOSUB 20750
IF FILESYS.PARAMETER > 1 OR NOT OK THEN _
RETURN
A1$ = "SEND"
GOSUB 20320
IF FILESYS.PARAMETER > 1 THEN _
RETURN
IF LOCAL.USER THEN _
CALL QTPUT1 ("Protocol not available in local mode") : _
RETURN
IF AUTODOWNLOAD.IN.PROGRESS THEN _
GOSUB 20294 : _
IF ABORT THEN _
RETURN
GOSUB 21300
IF FILESYS.PARAMETER > 1 THEN _
RETURN
A$ = ""
GOTO 20390
20294 CALL SENDNAME
RETURN
20318 A$ = "Please SWITCH to N,8,1 for binary transfer"
GOSUB 21630
IF FILESYS.PARAMETER > 1 THEN _
RETURN
CALL DELAYIT (3)
RETURN
20320 IF NOT EIGHT.BIT THEN _
GOSUB 20318 : _
IF FILESYS.PARAMETER > 1 THEN _
RETURN
20325 IF CHECKSUM THEN _
NEGATIVE.ACKNOWLEDGE$ = CHR$(21) : _
SOL = 132 _
ELSE NEGATIVE.ACKNOWLEDGE$ = "C" : _
SOL = 133
20330 IF AUTODOWNLOAD.IN.PROGRESS THEN _
RETURN
A$ = PROTO.PROMPT$ + _
" " + A1$ + _
" of " + _
FILE.NAME.HOLD$ + _
" ready. <Ctrl X> aborts"
GOSUB 21650
IF A1$ = "SEND" THEN _
CALL TALK (8,A$) _
ELSE CALL TALK (9,A$)
RETURN
'
' * ASCII DOWNLOAD DRIVER
'
20340 IF DF THEN _
A$ = "Switch to a non-ascii protocol" : _
GOSUB 21650 : _
GOTO 21700
GOSUB 20750
IF FILESYS.PARAMETER > 1 OR NOT OK THEN _
RETURN
CALL OPENWORK (2,FILE.NAME$)
IF (ANS.INDEX = FIRST.DOWNLOAD OR NOT CONCAT.FILES) THEN _ ' KG081201
A$ = "^X aborts. ^S suspends ^Q resumes" : _
GOSUB 21640 : _
IF FILESYS.PARAMETER > 1 THEN _
RETURN _
ELSE A$ = PROTO.PROMPT$ + " SEND of " + _
FILE.NAME.HOLD$ + _
" ready. Press Any Key to start" : _
TURBO.KEY = 2 : _
FORCE.KEYBOARD = TRUE : _ ' KG090101
GOSUB 21660 : _
IF FILESYS.PARAMETER > 1 THEN _
RETURN
20380 STOP.INTERRUPTS = FALSE
TU = 0
SWAP TU,PAGE.LENGTH
CALL BUFFILE (FILE.NAME$,X)
SWAP TU,PAGE.LENGTH
NON.STOP = (PAGE.LENGTH < 1)
IF STOP.FILE THEN _
DOWNLOAD.COMPLETED = FALSE : _
GOTO 20390
20381 IF (ANS.INDEX = LAST.DOWNLOAD OR NOT CONCAT.FILES) THEN _ ' KG081201
CALL QTPUT (CHR$(26),0) : _
IF NOT LOCAL.USER AND SUBROUTINE.PARAMETER = 0 THEN _
FOR X = 1 TO 5 : _
CALL PUTCOM (CHR$(7)) : _
CALL DELAYIT (3) : _
NEXT
20385 DOWNLOAD.COMPLETED = TRUE
20390 GOTO 21760
'
' * U - COMMAND FROM FILES MENU (UPLOAD)
'
20395 GOSUB 21640
IF FILESYS.PARAMETER > 1 THEN _
RETURN
A$ = "Correct name of file to upload" + _
PRESS.ENTER.EXPERT$
GOSUB 21660
IF FILESYS.PARAMETER > 1 THEN _
RETURN
IF Q = 0 THEN _
RETURN
B$(ANS.INDEX) = B$(1)
GOTO 20435
20400 CALL TIMEBACK (1) ' KG082701
GOSUB 20420 ' KG081201
FIRST.UPLOAD = ANS.INDEX ' KG081201
GOTO 20430
20420 A$ = "Upload what file(s)" ' KG081201
GOSUB 21668 ' KG081201
RETURN
'
' * SEARCH FOR DUPLICATE FILENAME
'
20430 Z$ = B$(LAST.INDEX) ' KG081201
IF LEN(Z$) = 1 THEN _
CALL ALLCAPS (Z$) : _
IF INSTR(DFLTXFER$,Z$) > 0 THEN _
LAST.INDEX = LAST.INDEX - 1 : _ ' KG081201
COMMAND.TRANSFER$ = Z$
FOR ANS.INDEX = FIRST.UPLOAD TO LAST.INDEX ' KG081201
GOSUB 20435
IF FILESYS.PARAMETER > 1 THEN _
ANS.INDEX = LAST.INDEX + 1 ' KG081201
NEXT
COMMAND.TRANSFER$ = ""
RETURN
20435 FILE.NAME.HOLD$ = B$(ANS.INDEX)
CALL ALLCAPS(FILE.NAME.HOLD$)
FILE.NAME$ = FILE.NAME.HOLD$
VIOLATION$ = "Upload "
' IF INSTR(FILE.NAME$,":") OR _
' INSTR(FILE.NAME$,"\") OR _
' INSTR(FILE.NAME$," ") OR _ 'Pe 06/06/89
' INSTR(FILE.NAME$,"*") OR _
' INSTR(FILE.NAME$,"?") OR _ 'Pe 06/06/89
' INSTR(FILE.NAME$,"/") THEN _
' GOTO 20451
CALL NOPATH (FILE.NAME$,BAD.FILE.NAME.INDEX) ' KG060801
IF BAD.FILE.NAME.INDEX THEN _ ' KG060801
GOTO 20451 ' KG060801
CALL BADFILE (FILE.NAME$,BAD.FILE.NAME.INDEX)
'comment out the NEXT 2 lines if you want to enable files without EXTENSION
'to regular users
'
IF EXT$ = "" AND USER.SECURITY.LEVEL < OVERWRITE.SECURITY.LEVEL THEN _
GOTO 20451 'Pe 12/22/88
'
ON BAD.FILE.NAME.INDEX GOTO 20440,20451,20515
20440 TMP.FILE.NAME$ ="NOTHANX.DEF" 'PE mode
CALL FINDIT (TMP.FILE.NAME$) 'DGS-UNW
IF OK THEN 'DGS-UNW
CALL QTPUT ("Checking off line file list....",1) 'Pe 02/11/89
OPEN TMP.FILE.NAME$ FOR INPUT AS #9 'DGS-UNW
HAV.FILE$ = "" 'DGS-UNW
FILE.IN.LIST = FALSE 'DGS-UNW
WHILE NOT EOF(9) AND NOT FILE.IN.LIST 'DGS-UNW
INPUT #9, HAV.FILE$ 'DGS-UNW
CALL ALLCAPS (HAV.FILE$) 'DGS-UNW
FILE.IN.LIST = (INSTR(FILE.NAME.HOLD$,HAV.FILE$) > 0) 'DGS-UNW
WEND 'DGS-UNW
CLOSE 9 'DGS-UNW
END IF 'DGS-UNW
IF FILE.IN.LIST THEN _ 'DGS-UNW
CALL BUFFILE ("NOTHANX.MSG",X) : _ 'Pe 02/19/89
GOTO 20453 'DGS-UNW
CALL ROTORSDIR (FILE.NAME$,SUBDIR$(),SUBDIR.COUNT,TRUE)
20450 IF OK THEN _
GOTO 20452
CLOSE 2 ' MC0220
OPEN "EXTCHECK.DEF" FOR INPUT AS #2 ' MC0220
DO WHILE NOT EOF(2) ' MC0220
INPUT #2, CHECK$ ' MC0220
IF INSTR(FILE.NAME$,".") AND _ ' MC0220
RIGHT$(FILE.NAME.HOLD$,3) <> CHECK$ THEN _ ' MC0220
FILE.NAME$ = LEFT$(FILE.NAME.HOLD$,LEN(FILE.NAME.HOLD$)-3) + _
CHECK$ : _ ' MC0220
CALL ROTORSDIR (FILE.NAME$,SUBDIR$(),SUBDIR.COUNT,TRUE) ' MC0220
IF OK THEN _ ' MC0220
GOTO 20452 ' MC0220
LOOP ' MC0220
CLOSE 2 ' MC0220
GOTO 20475
CALL BRKFNAME (FILE.NAME$,DR$,X$,EXTENTION$,FALSE)
IF EXTENTION$ = DEFAULT.EXTENSION$ THEN _
GOTO 20475
X$ = X$ + "." + DEFAULT.EXTENSION$
CALL ROTORSDIR (X$,SUBDIR$(),SUBDIR.COUNT,FALSE)
IF OK THEN _
FILE.NAME.HOLD$ = DEFAULT.EXTENSION$ + " ver of " + FILE.NAME.HOLD$ : _
GOTO 20454
GOTO 20475
20451 A$ = "Invalid file name. File name cannot contain a Drive letter"+CRLF$ +_
"Subdirectory name, a Space, or any WildCard Characters "
GOSUB 21655
CALL DELAYIT (2)
FILESYS.PARAMETER = 3
RETURN
20452 IF USER.SECURITY.LEVEL < OVERWRITE.SECURITY.LEVEL THEN _
GOTO 20453
A$ = "Overwrite file (Y,[N])"
GOSUB 21660
IF FILESYS.PARAMETER > 1 THEN _
RETURN
IF NOT YES THEN _
GOTO 20453
Z$ = FILE.NAME$
CALL KILLWORK (FILE.NAME$)
IF EC <> 0 THEN _
EL = 20452 : _
GOTO 21900
GOTO 20475
20453 CLOSE 2
IF USER.SECURITY.LEVEL >= ADD.DIR.SECURITY THEN _
GOTO 20455
20454 CALL QTPUT1 ("Thanks, but we already have " + FILE.NAME.HOLD$)
CALL UPDTCALR ("Upload duplicate " + FILE.NAME.HOLD$,1)
RETURN
20455 A$ = "Add new directory entry (Y,[N])"
TURBO.KEY = - TURBO.KEY.USER
GOSUB 21660
IF FILESYS.PARAMETER > 1 THEN _
RETURN
IF NOT YES THEN _
RETURN
ADDING.DESC.ONLY = TRUE
FT$ = "l"
CALL UPDTUPLOAD (CATEGORY.NAME$(),CATEGORY.CODE$(),LINES.IN.MESSAGE,1) 'UPL-MOD
GOSUB 20702
RETURN
20475 FILE.NAME$ = LEFT$(FILE.NAME$,LEN(FILE.NAME$)-3) + _ 'MC0220
RIGHT$(FILE.NAME.HOLD$,3) 'MC0220
Z$ = UPLOAD.DRIVE.FILE$
CALL FINDFREE
IF VAL(FREE.SPACE$) < 4096 THEN _
CALL QTPUT1 ("No room for uploads. Try tomorrow.") : _
ANS.INDEX = LAST.INDEX + 1 : _ ' KG081201
RETURN
A$ = "Upload disk has" + _
FREE.SPACE$
GOSUB 21640
IF FILESYS.PARAMETER > 1 THEN _
RETURN
'*****************
CALL UPDTUPLOAD (CATEGORY.NAME$(),CATEGORY.CODE$(),LINES.IN.MESSAGE,1) '<++++++
'*****************
IF ABORT THEN _ 'PE 12/14/88
ABORT = FALSE : _ 'PE 12/14/88
RETURN
LINE.25$ = "(U) " + _
FILE.NAME.HOLD$
SUBROUTINE.PARAMETER = 2
CALL LINE25
A$ = ""
OK = TRUE
20477 CALL XFERTYPE (2,TRUE)
IF FF THEN _
GOTO 20500
CALL XFERTYPE (1,TRUE)
IF SUBROUTINE.PARAMETER = -1 THEN _
FILESYS.PARAMETER = 7 : _ ' KG081201
RETURN
20500 CALL AUTOLOGOFF 'Autologoff mod
TRANSFER.FUNCTION = 2
AUTODOWNLOAD.IN.PROGRESS = FALSE
GOSUB 21790
IF FILESYS.PARAMETER > 1 THEN _
RETURN
ON INSTR("AXCYN",INTERNAL.PROTO$) GOTO _
20560, _ ' ASCII UPLOAD
20542, _ ' XMODEM
20542, _ ' XMODEM CRC
20542, _ ' YMODEM
20735 ' NONE - CANCEL
GOTO 20261
20510 D$ = "<Esc> by SYSOP aborts"
GOSUB 21710
RETURN
20515 CALL SVIOLATION
IF DENY.ACCESS THEN _
FILESYS.PARAMETER = 4 : _
RETURN
GOTO 20420
'
' * XMODEM/YMODEM UPLOAD DRIVER
'
20542 A1$ = "RECEIVE"
GOSUB 20320
IF FILESYS.PARAMETER > 1 THEN _
RETURN
OK = TRUE
GOSUB 20860
IF FILESYS.PARAMETER > 1 THEN _
RETURN
IF OK THEN _
GOTO 20700
GOTO 20730
'
' * ASCII UPLOAD
'
20560 LINE.ACK = (DEFAULT.LINE.ACK$ <> "")
IF LINE.ACK THEN _
A$ = "Acknowledge each line ([Y],N)" : _
TURBO.KEY = - TURBO.KEY.USER : _
LINE.ACK = NOT NO : _
GOSUB 21660 : _
IF FILESYS.PARAMETER > 1 THEN _
RETURN
CALL QTPUT1 ("Transfer MUST end with a <Ctrl-K>")
CALL QTPUT1 (PROTO.PROMPT$+" RECEIVE of " + FILE.NAME.HOLD$ + " ready")
OK = FALSE
XOFF = FALSE
CALL OPENOUTW(FILE.NAME$)
IF EC <> 0 AND EC <> 53 THEN _
EL = 20560 : _
GOTO 21900
GOSUB 20510
IF FILESYS.PARAMETER > 1 THEN _
RETURN
20600 CALL EOFCOMM (CHAR%)
WHILE CHAR% <> -1
CALL CARRIER
IF SUBROUTINE.PARAMETER = -1 THEN _
FILESYS.PARAMETER = 7 : _
RETURN
IF NOT FOSSIL THEN _
IF LOF(3) < 512 THEN _
CALL PUTCOM(XOFF$) : _
XOFF = TRUE
20610 CALL FLUSHCOM (X$)
IF SUBROUTINE.PARAMETER = -1 THEN _
FILESYS.PARAMETER = 7 : _ ' KG081201
RETURN
IF INSTR(X$,CHR$(11)) THEN _
GOTO 20650
OK = TRUE
20620 CALL PRINTWRK (X$)
IF LINE.ACK THEN _
IF INSTR(X$,CHR$(10)) > 0 THEN _
CALL PUTCOM (DEFAULT.LINE.ACK$)
IF EC <> 0 THEN _
EL = 20620 : _
GOTO 21900
D$ = X$
NUM.RETURNS = 0
GOSUB 21720
IF FILESYS.PARAMETER > 1 THEN _
RETURN
20621 CALL FINDFUNC
IF SUBROUTINE.PARAMETER < 0 THEN _
FILESYS.PARAMETER = 2 : _
RETURN
IF KEY.PRESSED$ = ESCAPE$ THEN _
GOTO 20745
IF NOT OK THEN _
GOTO 20670
CALL EOFCOMM (CHAR%)
20630 WEND
CALL CARRIER
IF SUBROUTINE.PARAMETER = -1 THEN _
FILESYS.PARAMETER = 7 : _
RETURN
IF XOFF THEN _
XOFF = FALSE : _
CALL PUTCOM (XON$) : _
IF EC <> 0 THEN _
EL = 20630 : _
GOTO 21900
GOTO 20600
20650 X = INSTR(X$,CHR$(11))
IF X = 1 THEN _
IF NOT OK THEN _
GOTO 20730 _
ELSE GOTO 20700
CALL PRNTWRKA (LEFT$(X$,X-1))
IF EC <> 0 THEN _
EL = 20650 : _
GOTO 21900
GOTO 20700
20670 A$ = XOFF$ + _
"System error! Upload aborted <Ctrl-K> continues"
20675 GOSUB 21650
IF FILESYS.PARAMETER > 1 THEN _
RETURN
CALL DELAYIT (3)
CALL PUTCOM(XON$)
20680 CALL EOFCOMM (CHAR%)
WHILE CHAR% <> -1
CALL FLUSHCOM(X$)
IF INSTR(X$,CHR$(11)) THEN _
GOTO 20730
20685 CALL CARRIER
IF SUBROUTINE.PARAMETER = -1 THEN _
FILESYS.PARAMETER = 7 : _
RETURN
CALL EOFCOMM (CHAR%)
WEND
GOTO 20680
'
' * UPDATE UPLOAD DIRECTORY
'
20700 GOSUB 21780
IF FILESYS.PARAMETER > 1 THEN _
RETURN
20702 CALL UPDTUPLOAD (CATEGORY.NAME$(),CATEGORY.CODE$(),LINES.IN.MESSAGE,2) '<++++++
'***** AUTO UP MOD *****
IF AUTO.END = 1 THEN _ 'AUTO-UP MOD to next comment
CALL BRKFNAME (FILE.NAME$,DR$,X$,EXTENTION$,TRUE): _
Z$ = X$+EXTENTION$+DF$+" at "+TIM$ +" using " + FT$ + STR$(BYTES.IN.FILE#) :_
CALL UPDTCALR (Z$,2) : _
RETURN 'AUTO-UP MOD
'***** end of Auto Up Mod****
PRIVATE.DOOR = FALSE
IF NOT GET.EXT.DESC THEN _
GOTO 20710
MSG.HEADER$ = "Extended Description for " + FILE.NAME.HOLD$ ' KG072003
SYSOP.COMMENT = TRUE
MAX.MESSAGE.LINES = MAX.EXTENDED.LINES
LL = RIGHT.MARGIN
RIGHT.MARGIN = 30 + MAX.DESC.LEN
FILESYS.PARAMETER = 5
RETURN
20705 MAX.MESSAGE.LINES = MAX.MESSAGE.LINES.DEF
RIGHT.MARGIN = LL
CALL UPDTUPLOAD (CATEGORY.NAME$(),CATEGORY.CODE$(),LINES.IN.MESSAGE,3) '<++++++
20710 ADDING.DESC.ONLY = FALSE
IF BYTES.IN.FILE# > 0.0 THEN _
GOTO 21770
20730 GOSUB 21780
CALL QTPUT1 ("Upload aborted")
PRIVATE.DOOR = FALSE
20735 CALL KILLWORK (FILE.NAME$)
IF EC <>0 THEN _
EL = 20736 : _
GOTO 21900
RETURN
'
' * SYSOP ABORTED UPLOAD
'
20745 A$ = XOFF$ + _
"SYSOP aborted upload. Stop tranfer. <Ctrl-K> continues"
GOTO 20675
'
' * CALCULATE DOWNLOAD TIME ESTIMATE
'
20750 START.OF.HEADER$ = CHR$(1 - (INTERNAL.PROTO$ = "Y"))
CALL OPENRSEQ (FILE.NAME$,MAX.BLOCK,DF,FLEN)
20760 IF EC <> 0 THEN _
CALL QTPUT1 ("Unable to access "+FILE.NAME.HOLD$) : _
CALL UPDTCALR ("Unable to access "+FILE.NAME$,2) : _
OK = FALSE : _
EC = 0 : _
BYTES.IN.FILE# = 0 : _
RETURN
BYTES.IN.FILE# = LOF(2)
NUM.DNLD.BYTS! = LOF(2)
OK = TRUE
IF SIZE.ONLY THEN _
SIZE.ONLY = FALSE : _
RETURN
BLOCKS.IN.FILE# = MAX.BLOCK
IF BATCH.TRANSFER THEN _
TEMP# = BATCH.BLOCKS# + BLOCKS.IN.FILE# : _ ' KG081502
CALL CHKTREMAIN (TIME.REMAINING!) : _ ' KG081502
IF (INT(TEMP# / 60) + 1) > INT(TIME.REMAINING!) THEN _ ' KG081502
CALL QTPUT1 ("Omitting " + FILE.NAME.HOLD$ + ". Insufficient time") : _ ' KG081502
RETURN _ ' KG081502
ELSE BATCH.BLOCKS# = TEMP# : _ ' KG081502
BATCH.BYTES# = BATCH.BYTES# + BYTES.IN.FILE# : _ ' KG081502
CALL OPENWRKA (NODE.WORK.FILE$) : _ ' KG081502
CALL PRNTWRKA (FILE.NAME$) : _ ' KG081502
RETURN ' KG081502
20780 A$ = "File Size :"
OK = TRUE
IF BLOCK.SIZE > 0 THEN _
A$ = A$ + _
STR$(FIX(BLOCKS.IN.FILE#)) + _
" blocks "
20785 BLOCKS.IN.FILE# = BLOCKS.IN.FILE# / _
VAL(MID$("0000030004501200240048009601920", -4 * BPS, 4))
BLOCKS.IN.FILE# = BLOCKS.IN.FILE# * FLEN / SPEED.FACTOR!
IF (ANS.INDEX > 1 AND CONCAT.FILES) THEN _ ' KG081201
RETURN
A$ = A$ + _
STR$(BYTES.IN.FILE#) + _
" bytes"
GOSUB 21650
IF FILESYS.PARAMETER > 1 THEN _
RETURN
IF BYTES.IN.FILE# < 1 THEN _
RETURN
20790 SUBROUTINE.PARAMETER = 2
CALL LINE25
A$ = "Transfer Time:" + _
STR$(INT(BLOCKS.IN.FILE# / 60)) + _
" min," + _
STR$(INT(BLOCKS.IN.FILE# - (INT(BLOCKS.IN.FILE# / 60) * 60))) + _
" sec (approx)"
GOSUB 21650
IF FILESYS.PARAMETER > 1 THEN _
RETURN
20791 IF PERSONAL.DOWNLOAD THEN _
RETURN
CALL CHKTREMAIN (TIME.REMAINING!)
IF SUBROUTINE.PARAMETER = -1 THEN _
FILESYS.PARAMETER = 6 : _
RETURN
OK = TRUE
IF (INT(BLOCKS.IN.FILE# / 60) + 1) > INT(TIME.REMAINING!) THEN _
A$ = "Not enough time left!" : _
CALL UPDTCALR (FILE.NAME$ + " " + A$,2) : _
CALL QTPUT1 (A$): _
A$ = "" : _
OK = FALSE : _
RETURN
CALL AUTOLOGOFF 'Autologoff mod
CALL CHECKRATIO (TRUE)
'
'
' *** Tell-m.mod as of 09/10/89****** Pete E
'
'
If NOT OK THEN _
RETURN 'Pe 08/27/89
'
NOTIFY$ = WELCOME.FILE.DRV.PATH$ + _
"TELTHEM.DEF" ' <==== NOTE SPELLING
CALL FINDIT (NOTIFY$)
IF OK THEN _
STOP.INTERRUPTS = TRUE : _
CALL BUFFILE (NOTIFY$,X)
'***************************************
RETURN
20810 CALL SETABORT (DELAY!,6)
20840 CALL EOFCOMM (CHAR%)
IF CHAR% = -1 THEN _
GOTO 20850
CALL FLUSHCOM(Y$)
RETURN
20850 CALL CHECKTIM (DELAY!)
ON SUBROUTINE.PARAMETER GOTO 20840,20851
20851 Y$ = ""
CALL CHKCARRIER ' KG061203
IF SUBROUTINE.PARAMETER = -1 THEN _
FILESYS.PARAMETER = 7 : _
RETURN
RETURN
'
' * XMODEM/YMODEM UPLOAD
'
20860 GOSUB 20992
IF FILESYS.PARAMETER > 1 THEN _
RETURN
IF NOT EIGHT.BIT THEN _
GOSUB 21280 : _
IF FILESYS.PARAMETER > 1 THEN _
RETURN
20900 X$ = ""
SEC = 1
'CALL OPENOUTW (FILE.NAME$)
IF FLEN > WRITE.BUF.DEF THEN _
WRITE.BUF = FLEN _
ELSE WRITE.BUF = WRITE.BUF.DEF
CALL OPENRSEQ (FILE.NAME$,Y,DF,WRITE.BUF)
IF EC <> 0 AND EC <> 53 THEN _
EL = 20900 : _
GOTO 21900
FIELD #2, WRITE.BUF AS UPLOAD.RECORD$
RECS.WRIT = 0
NUM.IN.BUFF = 0
CALL SETABORT (TRANSFER.ABORT!,WAIT.BEFORE.DISCONNECT)
YY$ = " " + _
CHR$(1) + _
CHR$(2) + _
END.TRANSMISSION$ + _
CANCEL$
20903 CALL PUTCOM (NEGATIVE.ACKNOWLEDGE$)
20920 X = 1
20922 CALL CHKCARRIER ' KG061203
IF SUBROUTINE.PARAMETER = -1 THEN _
FILESYS.PARAMETER = 7 : _
RETURN
CALL FINDFUNC
IF KEY.PRESSED$ = ESCAPE$ THEN _
GOSUB 20510 :_
IF FILESYS.PARAMETER > 1 THEN _
RETURN _
ELSE GOTO 21240
GOSUB 20810
IF FILESYS.PARAMETER > 1 THEN _
RETURN
20930 J = INSTR(YY$,LEFT$(Y$,1))
ON J GOTO 20960,20999,20999,21220,21230
20960 IF Y$ <> "" THEN _
GOSUB 21280 : _
IF FILESYS.PARAMETER > 1 THEN _
RETURN _
ELSE CALL CHECKTIM (TRANSFER.ABORT!) : _
ON SUBROUTINE.PARAMETER GOTO 20920,21230
20970 X = X + 1
CALL DELAYIT (1)
CALL PUTCOM (NEGATIVE.ACKNOWLEDGE$)
IF X < 6 THEN _
GOTO 20922
D$ = "Upload Timeout"
GOSUB 21710
IF FILESYS.PARAMETER > 1 THEN _
RETURN
CALL CHECKTIM (TRANSFER.ABORT!)
ON SUBROUTINE.PARAMETER GOTO 20990,21230
20990 GOTO 20920
'
' * CHANGE TO 8 BIT FOR XMODEM
'
20992 GOSUB 20510
IF FILESYS.PARAMETER > 1 THEN _
FILESYS.PARAMETER = 2 : _
RETURN
IF NOT EIGHT.BIT THEN _
PREV.LINE.CONTROL = INP (LINE.CONTROL.REGISTER) : _
CALL DELAYIT (3) : _
SWITCHED.TO.EIGHT = TRUE : _
OUT LINE.CONTROL.REGISTER,3
20996 SO = 0
RETURN
'
' * EXPECTED BLOCK LENGTH. 132 FOR CHECKSUM, 133 FOR CRC, 1029 FOR YMODEM
'
20999 SOL = 896 * J - 1659 + CHECKSUM
DATA.SOL = 128 - (SOL > 1024)*896
GOTO 21020
'
' * XMODEM/YMODEM UPLOAD
'
21000 GOSUB 20810
IF FILESYS.PARAMETER > 1 THEN _
RETURN
IF Y$ = "" THEN _
D$ = "Upload Timeout" : _
GOSUB 21710 : _
IF FILESYS.PARAMETER > 1 THEN _
RETURN _
ELSE GOTO 21040
21020 X$ = X$ + _
Y$
IF LEN(X$) < SOL THEN _
GOTO 21000
21040 IF LEN(X$) = SOL THEN _
GOTO 21090
21050 IF LEN(X$) > SOL THEN _
GOTO 21180
21060 IF X$ = END.TRANSMISSION$ THEN _
GOTO 21220
21070 IF X$ = CANCEL$ THEN _
GOTO 21230
21080 GOTO 21170
21090 JX = ASC(MID$(X$,2,1))
IF SEC = JX THEN _
GOTO 21100
IF SEC > JX THEN _
CALL PUTCOM (RIGHT$(ACKC$,1 - (JX = 0))) : _
GOTO 21150
GOTO 21200
21100 IF (SEC XOR 255) <> ASC(MID$(X$,3,1)) THEN _
GOTO 21210
21110 IF CHECKSUM THEN _
WK$ = MID$(X$,4,128) : _
GOSUB 21750 : _
IF FILESYS.PARAMETER > 1 THEN _
RETURN _
ELSE IF XMODEM.CHECKSUM <> ASC(MID$(X$,132,1)) THEN _
GOTO 21190 _
ELSE GOTO 21120
WK$ = MID$(X$,4)
GOSUB 21750
IF FILESYS.PARAMETER > 1 THEN _
RETURN
21113 IF CRC.VALUE <> 0 THEN _
GOTO 21191
21120 SO = SO + 1
CALL PUTCOM (ACKNOWLEDGE$)
21131 IF NUM.IN.BUFF >= WRITE.BUF THEN _
NUM.IN.BUFF = 0 : _
CALL PUTWORK (UPLOAD.RECORD$,RECS.WRIT,WRITE.BUF) : _
IF EC <> 0 THEN _
EL = 21131 : _
GOTO 21900
MID$(UPLOAD.RECORD$,NUM.IN.BUFF+1,DATA.SOL) = WK$
NUM.IN.BUFF = NUM.IN.BUFF + DATA.SOL
21145 SEC = 255 AND (SEC + 1)
CALL QLPRNT ("OK Rec Blk #",SO)
21150 X$ = ""
XMODEM.CHECKSUM = 0
CALL SETABORT(TRANSFER.ABORT!,45)
GOTO 20920
21170 A$ = "Short Blk #"
GOTO 21212
21180 A$ = "Long Blk #"
GOTO 21212
21190 A$ = "Chksum Error #"
GOTO 21212
21191 A$ = "CRC Error"
GOTO 21212
21200 A$ = "Blk # Error in #"
JX = ASC(MID$(X$,2,1))
IF SEC < JX THEN _
GOTO 21212
CALL PUTCOM (ACKNOWLEDGE$) ' RIGHT$(ACKC$,1 - (JX = 0)))
GOTO 21150
21210 A$ = "Complement Error in #"
21212 GOSUB 21280
IF FILESYS.PARAMETER > 1 THEN _
RETURN
CALL PUTCOM (NEGATIVE.ACKNOWLEDGE$)
CALL LPRNT(LINE.FEED$ + A$ + STR$(SO + 1),0)
GOTO 21150
21220 IF NUM.IN.BUFF < 1 THEN _
GOTO 21225
WK$ = LEFT$(UPLOAD.RECORD$,NUM.IN.BUFF)
CALL OPENRSEQ (FILE.NAME$,MAX.BLOCK,DF,128)
FIELD #2, 128 AS UPLOAD.RECORD$
MAX.BLOCK = CDBL(RECS.WRIT) * WRITE.BUF / 128
FOR I = 1 TO NUM.IN.BUFF/128
CALL PUTWORK (MID$(WK$,128*I-127,128),MAX.BLOCK,128)
IF EC > 0 THEN _
EL = 21220 : _
GOTO 21900
NEXT
CLOSE 2
21225 CALL PUTCOM (ACKNOWLEDGE$)
GOTO 21250
21230 D$ = LINE.FEED$ + _
"Transfer Aborted"
GOSUB 21710
IF FILESYS.PARAMETER > 1 THEN _
RETURN
21240 CALL EOFCOMM (CHAR%)
IF CHAR% <> -1 THEN _
GOSUB 21280 : _
IF FILESYS.PARAMETER > 1 THEN _
RETURN _
ELSE CALL DELAYIT (1) : _
GOTO 21240
CALL PUTCOM (CANCEL$ + CANCEL$)
CALL DELAYIT (1)
CALL EOFCOMM (CHAR%)
IF CHAR% <> -1 THEN _
GOTO 21240
OK = FALSE
21250 EIGHT.BIT = TRUE
RETURN
'
' * CLEAR GARBAGE OUT OF COMMUNICATIONS BUFFER
'
21280 CALL CHKCARRIER ' KG061203
IF SUBROUTINE.PARAMETER = -1 THEN _
FILESYS.PARAMETER = 7 : _
RETURN
CALL EOFCOMM (CHAR%)
IF CHAR% = -1 THEN _
RETURN
21281 CALL FLUSHCOM(DF$)
IF SUBROUTINE.PARAMETER = -1 THEN _
FILESYS.PARAMETER = 7 : _ ' KG081201
RETURN
GOTO 21280
'
' * XMODEM/YMODEM DOWNLOAD
'
21300 GOSUB 20992
IF FILESYS.PARAMETER > 1 THEN _
RETURN
SEC = 0
GOSUB 21280
IF FILESYS.PARAMETER > 1 THEN _
RETURN
NEGATIVE.ACKNOWLEDGE$ = CHR$(21)
CALL SETABORT (TRANSFER.ABORT!,WAIT.BEFORE.DISCONNECT)
CALL OPENRSEQ (FILE.NAME$,MAX.BLOCK,DF,FLEN) 'Pe 08/15/89
21303 FIELD 2,FLEN AS DOWNLOAD.RECORD$
'
' * ROUTINE TO START AN "XMODEM" OR "YMODEM" DOWNLOAD. CHECK'S INITIAL
' * "HANDSHAKE" TO SEE IF CHARACTER IS SENT IS A:
' * "X" = XMODEM WITH CHECKSUM AND 128 CHARACTER RECORDS
' * "C" = XMODEM WITH CRC CHECK AND 128 CHARACTER RECORDS
' * "Y" = YMODEM WITH CRC CHECK AND 1024 CHARACTER RECORDS
'
21350 CALL EOFCOMM (CHAR%)
WHILE CHAR% <> -1
21360 CALL GETCOM(Y$)
IF Y$ = CANCEL$ THEN _
GOTO 21560
21380 CHECKSUM = (Y$ = NEGATIVE.ACKNOWLEDGE$)
IF CHECKSUM THEN _
FF = INSTR(INTERNAL.EQUIV$,"X") : _
IF FF > 0 THEN _
FT$ = MID$(DFLTXFER$,FF,1) : _
GOTO 21480 _
ELSE FT$ = "X" : _
GOTO 21480 _
ELSE IF Y$ = "C" THEN _
GOTO 21480
CALL EOFCOMM (CHAR%)
21390 WEND
GOSUB 21460
IF FILESYS.PARAMETER > 1 THEN _
RETURN
IF KEY.PRESSED$ = ESCAPE$ THEN _
RETURN
CALL CHECKTIM (TRANSFER.ABORT!)
ON SUBROUTINE.PARAMETER GOTO 21350,21455
21410 CALL SETABORT (TRANSFER.ABORT!, WAIT.BEFORE.DISCONNECT)
'
' * ROUTINE TO WAIT FOR AN ACKNOWLEDGEMENT ON AN "XMODEM" OR "YMODEM"
' * DOWNLOAD
'
21415 CALL EOFCOMM (CHAR%)
IF CHAR% <> -1 THEN _
GOTO 21420
GOSUB 21460
IF FILESYS.PARAMETER > 1 THEN _
RETURN
IF KEY.PRESSED$ = ESCAPE$ THEN _
RETURN
CALL CHECKTIM (TRANSFER.ABORT!)
ON SUBROUTINE.PARAMETER GOTO 21415,21455
21420 CALL GETCOM(Y$)
IF Y$ = ACKNOWLEDGE$ THEN _
GOTO 21470
21440 IF Y$ <> NEGATIVE.ACKNOWLEDGE$ THEN _
GOTO 21450
21443 D$ = LINE.FEED$ + _
"Error -> retrans #" + _
STR$(SO)
GOSUB 21710
IF FILESYS.PARAMETER > 1 THEN _
RETURN
21445 SO = SO - 1
GOTO 21490
21450 IF Y$ = CANCEL$ THEN _
IF HAVE.A.CANCEL THEN _
GOTO 21560 _
ELSE HAVE.A.CANCEL = TRUE
CALL CHECKTIM (TRANSFER.ABORT!)
ON SUBROUTINE.PARAMETER GOTO 21415,21455
21455 D$ = "Download timeout"
GOSUB 21710
IF FILESYS.PARAMETER > 1 THEN _
RETURN
GOTO 21560
21460 CALL CHKCARRIER ' KG061203
CALL FINDFUNC
IF SUBROUTINE.PARAMETER < 0 THEN _
FILESYS.PARAMETER = 7 : _
RETURN
IF KEY.PRESSED$ = ESCAPE$ THEN _
GOTO 21540
RETURN
'
' * DISPLAY BLOCK SENT OK AND THEN READ IN NEXT RECORD FROM DISK TO DOWNLOAD
'
21470 CALL QLPRNT ("OK Sent Blk #",SO)
21480 IF LOC(2) => MAX.BLOCK THEN _
GOTO 21530
CALL GETWORK (FLEN)
IF EC <> 0 THEN _
EL = 21480 : _
GOTO 21900
SEC = 255 AND (SEC + 1)
GOTO 21490
'
' * ROUTINE TO WRITE OUT AN "XMODEM" OR "YMODEM" RECORD TO THE COMM. PORT
'
21490 SO = SO + 1
CALL PUTCOM (START.OF.HEADER$ + CHR$(SEC) + CHR$(SEC XOR 255))
CALL PUTCOM (DOWNLOAD.RECORD$)
HAVE.A.CANCEL = FALSE
21503 WK$ = DOWNLOAD.RECORD$
21504 GOSUB 21750
IF FILESYS.PARAMETER > 1 THEN _
RETURN
21510 IF CHECKSUM THEN _
CALL PUTCOM(CHR$(XMODEM.CHECKSUM)) _
ELSE CALL PUTCOM(CHR$(CRC.HIGH) + CHR$(CRC.LOW))
GOSUB 21280
IF FILESYS.PARAMETER > 1 THEN _
RETURN
GOTO 21410
'
' * END-OF-FILE FOR XMODEM DOWNLOADS -- SEND THE "EOT" CHARACTER AND WAIT UP
' * TO 2 SECONDS FOR A POSITIVE RESPONSE (I.E. AN "ACK"). IF NONE IS
' * RE-TRY UP TO 10 TIMES. IF NO POSITIVE RESPONSE IS RECEIVED AFTER TEN
' * ATTEMPTS, ASSUME THE DOWNLOAD WAS UNSUCCESSFULL.
'
21530 CALL PUTCOM (END.TRANSMISSION$)
X = 1
21531 GOSUB 20810
IF FILESYS.PARAMETER > 1 THEN _
RETURN
IF INSTR(Y$,ACKNOWLEDGE$) THEN _
GOTO 21550
CALL FINDFUNC
IF SUBROUTINE.PARAMETER < 0 THEN _
FILESYS.PARAMETER = 2 : _
RETURN
IF KEY.PRESSED$ = ESCAPE$ THEN _
GOSUB 21540 : _
GOTO 21545
IF X < 10 THEN _
X = X + 1 : _
GOTO 21531
DOWNLOAD.COMPLETED = FALSE
GOTO 21230
21540 GOSUB 20510
IF FILESYS.PARAMETER > 1 THEN _
RETURN
RETURN
21545 Y$ = CANCEL$
CALL PUTCOM (CANCEL$ + CANCEL$ + CANCEL$)
DOWNLOAD.COMPLETED = FALSE
GOTO 21250
21550 DOWNLOAD.COMPLETED = TRUE
GOTO 21250
21560 DOWNLOAD.COMPLETED = FALSE
D$ = LINE.FEED$ + _
"Caller aborted trans"
GOSUB 21710
IF FILESYS.PARAMETER > 1 THEN _
RETURN
GOTO 21545
'
' STANDARD ENTRY FOR RBBS-PC'S COMMON TERMINAL OUTPUT ROUTINE
'
' Modeled on lines 12975 to 12983 in RBBS-PC.BAS
21630 SUBROUTINE.PARAMETER = 1
GOTO 21655
21640 SUBROUTINE.PARAMETER = 3
GOTO 21655
21650 SUBROUTINE.PARAMETER = 5
21655 CALL TPUT
IF SUBROUTINE.PARAMETER < 0 THEN _
FILESYS.PARAMETER = 2 : _
RETURN
IF SUBROUTINE.PARAMETER = 8 THEN _
GOSUB 21660
RETURN
'
' STANDARD ENTRY FOR RBBS-PC'S COMMON TERMINAL INPUT ROUTINE
'
' Modeled on lines 12995 to 12997 in RBBS-PC.BAS
21660 SUBROUTINE.PARAMETER = 1
CALL TGET
21665 IF SUBROUTINE.PARAMETER < 0 THEN _ ' KG081201
FILESYS.PARAMETER = 2
RETURN
21668 CALL POPCSTACK ' KG081201
GOTO 21665 ' KG081201
21700 EC = 0
RETURN
'
' **** COMMON LOCAL DISPLAY PRINT ***
'
' (formerly lines 1315 to 1320 in RBBS-PC.BAS CPC16-1A
21710 NUM.RETURNS = 1
21720 CALL LPRNT (D$,NUM.RETURNS)
RETURN
'
' * XMODEM / CRC INTERFACE
'
' (formerly line 46000 in RBBS-PC.BAS CPC16-1A
21750 XMODEM.CHECKSUM = 0
CRC.VALUE = 0
CALL XMODEM(WK$,XMODEM.CHECKSUM,CRC.VALUE,CRC.HIGH,CRC.LOW)
RETURN
'
' * UPDATE DOWNLOAD STATISTICS
'
' (formerly lines 50600 to 50614 in RBBS-PC.BAS CPC16-1A
21760 GOSUB 21780
IF FILESYS.PARAMETER > 1 THEN _
RETURN
IF BATCH.TRANSFER THEN _
CALL LINESNFIL (NODE.WORK.FILE$,DOWN.FILES) _
ELSE DOWN.FILES = 1
IF NOT DOWNLOAD.COMPLETED THEN _
AUTO.LOGOFF = FALSE : _
DF$ = " Aborted" _
ELSE CALL LOGDOWN (PERSONAL.DOWNLOAD,1+ANS.INDEX-FIRST.DOWNLOAD) : _ ' KG082601
DOWNLOADS = DOWNLOADS + DOWN.FILES : _
GLOBAL.DL.TODAY! = GLOBAL.DL.TODAY! + DOWN.FILES : _
GLOBAL.DOWNLOADS = GLOBAL.DOWNLOADS + DOWN.FILES : _
DLBYTES! = DLBYTES! + NUM.DNLD.BYTS! : _
GLOBAL.DLBYTES! = GLOBAL.DLBYTES! + NUM.DNLD.BYTS! : _
DL.TODAY! = DL.TODAY! + DOWN.FILES : _
BYTES.TODAY! = BYTES.TODAY! + NUM.DNLD.BYTS! : _
GLOBAL.BYTES.TODAY! = GLOBAL.BYTES.TODAY! + NUM.DNLD.BYTS! : _ ' KG102004
NUM.DNLD.BYTS! = 0 : _
CALL MUZAK (6) : _
DF$ = " Downloaded" : _
IF (ANS.INDEX = LAST.DOWNLOAD OR NOT CONCAT.FILES) THEN _ ' KG081201
CALL SKIPLINE (1) : _
CALL QTPUT1 ("Download successful")
IF AUTODOWNLOAD.IN.PROGRESS THEN _
DF$ = " AUTO" + _
MID$(N$,2)
IF INSTR(N$,"Aborted") THEN _
AUTODOWNLOAD.IN.PROGRESS = 0
A$ = ""
21770 CALL AMORPM ' KG061203
IF NOT BATCH.TRANSFER THEN _
GOTO 21773
CALL OPENWORK (2,NODE.WORK.FILE$)
IF EC > 0 THEN _
RETURN
Q = 0
WHILE NOT EOF(2)
CALL READANY
Q = Q + 1
B$(Q) = A$
WEND
21772 IF Q < 1 THEN _
BATCH.TRANSFER = FALSE : _
CALL CHECKRATIO (FALSE):_
RETURN
CALL OPENWORK (2,B$(Q))
IF EC > 0 THEN _
EC = 0 : _
Q = Q - 1 : _
GOTO 21772
BYTES.IN.FILE# = LOF(2)
FILE.NAME$ = B$(Q)
21773 CALL BRKFNAME (FILE.NAME$,DR$,X$,EXTENTION$,TRUE)
Z$ = X$ + _
EXTENTION$ + _
DF$ + _
" at " + _
TIM$ + _
" using " + _
FT$ + _
STR$(BYTES.IN.FILE#)
CALL UPDTCALR (Z$,2)
IF BATCH.TRANSFER THEN _
Q = Q - 1 : _
GOTO 21772
CALL CHECKRATIO (FALSE)
21774 IF MENU.INDEX = 6 THEN _
IF DOWNLOAD.COMPLETED THEN _
A$ = X$ : _
SUBROUTINE.PARAMETER = 5 : _
CALL LIBRARY
RETURN
'
' ***** TURN ON INTERMEDIATE ECHO ****
'
' (formerly line 50620 in RBBS-PC.BAS CPC16-1A
21780 IF ECHOER$ = "I" THEN _
CALL SETECHO ("I")
'
' * RESTORE COMMUNICATIONS AFTER SWITCH TO 8 BIT
'
' (formerly between lines 50620 and 50630 in RBBS-PC.BAS CPC16-1A
IF SWITCHED.TO.EIGHT THEN _
IF SWITCH.BACK THEN _
OUT LINE.CONTROL.REGISTER, PREV.LINE.CONTROL : _
CALL DELAYIT (3) : _
EIGHT.BIT = FALSE : _
SWITCHED.TO.EIGHT = FALSE
RETURN
'
' ***** TURN OFF INTERMEDIATE ECHO ****
'
' (formerly line 50630 in RBBS-PC.BAS CPC16-1A
21790 IF ECHOER$ = "I" THEN _
CALL SETECHO ("R")
RETURN
'
' ***** DIRECTORY SEARCH ****
'
' (formerly lines 52900 to 52920 in RBBS-PC.BAS CPC16-1A
21800 CK = 2 ' KG081201
21810 A$ = "Search for (in file name/desc, wildcards name only, [ENTER] quits)"
MACRO.MIN = 99
GOSUB 21668 ' KG081201
IF Q = 0 THEN _
RETURN
21820 RS$ = B$(ANS.INDEX) ' KG081201
WILD.SEARCH = (INSTR(RS$,"*") > 0 OR INSTR(RS$,"?") > 0)
CALL ALLCAPS (RS$)
SEARCH.STRING$ = RS$
SEARCH.DATE$ = ""
A1$ = RS$
GOTO 21867
'
' ***** P - personal download ****
'
' (formerly lines 52950 to 52952 in RBBS-PC.BAS CPC16-1A
21850 IF PERSONAL.BEGIN < 1 OR PERSONAL.LEN < 1 THEN _
RETURN
DOWNLOAD.FLAG = 0
PERSONAL.DOWNLOAD = TRUE
21852 CALL PERSFILE (MID$(USER.RECORD$,PERSONAL.BEGIN,PERSONAL.LEN),_
DOWNLOAD.FLAG)
IF SUBROUTINE.PARAMETER = -1 THEN _
FILESYS.PARAMETER = 7: _
RETURN
IF LAST.INDEX <= 0 THEN _ ' KG082601
GOTO 21854
CONCAT.FILES = PERSONAL.CONCAT
STOP.INTERRUPTS = TRUE
TIME.LOCK.EXEMPT = TRUE
GOSUB 20202
IF FILESYS.PARAMETER > 1 THEN _
GOTO 21854
TIME.LOCK.EXEMPT = FALSE
CONCAT.FILES = FALSE
GOTO 21852
21854 PERSONAL.DOWNLOAD = FALSE
RETURN
'
' * N - COMMAND FROM FILES MENU (DISPLAY NEW FILES SINCE LAST DIR DISPLAY)
'
' (formerly lines 53000 to 53070 in RBBS-PC.BAS CPC16-1A
21860 CK = 1 ' KG081201
21862 A1$ = RIGHT$(LM$,4) +_
LEFT$(LM$,2)
A$ = "Files on/after (MMDDYY, [ENTER] = last on " + _
A1$ + _
")"
GOSUB 21668 ' KG081201
IF Q = 0 THEN _
RS$ = LM$ : _
GOTO 21866 ' KG081202
21865 IF LEN(B$(ANS.INDEX)) <> 6 THEN _ ' KG081201
GOTO 21862
A1$ = B$(ANS.INDEX) ' KG081201
RS$ = RIGHT$(A1$,2) + _
LEFT$(A1$,4)
21866 SEARCH.DATE$ = RS$
SEARCH.STRING$ = ""
LIST.NEW = TRUE 'Pe 09/10/89
21867 '
21871 B$(1) = "ALL"
CALL CONVDIRS (ANS.INDEX) ' KG090205
LIST.DIRECTORY = TRUE ' KG083002
SEARCHING.ALL = TRUE ' Pe 09/10/89
21875 Z$ = B$(ANS.INDEX) ' KG081201
IF NOT SEARCHING.ALL THEN _ ' KG081201
IF Z$ = "ALL" THEN _ ' KG081201
IF NOT LIMIT.SEARCH.TO.FMS THEN _ ' KG081201
GOTO 21890 ' KG081201
21880 QX = ANS.INDEX ' KG081201
GOSUB 20157 ' KG081201
IF FILESYS.PARAMETER > 1 THEN _
RETURN
ANS.INDEX = ANS.INDEX + 1 ' KG081201
IF ANS.INDEX <= LAST.INDEX THEN _ ' KG090205
GOTO 21875
LIST.NEW = FALSE
SEARCH.STRING$ = ""
SEARCH.DATE$ = ""
RETURN
21890 G = ANS.INDEX ' KG083002
CALL GETALL (DIRECTORY.PATH$ + DIRECTORY.PREFIX$ + "." + DIRECTORY.EXTENTION$,B$(),DIRECTORY.EXTENTION$,G)
SEARCHING.ALL = TRUE
LAST.INDEX = G ' KG081201
ANS.INDEX = ANS.INDEX + 1 ' KG081201
GOTO 20157 ' KG081201
'
' * MAIN FILE SYSTEM ERROR TRAP - ALL ERRORS PASS THROUGH THIS ROUTINE
'
' (formerly lines 13000 to 13500 in RBBS-PC.BAS CPC16-1A
21900 IF DEBUG THEN _
A$ = "RBBSSUB5 DEBUG Error Trap Entry ERL=" + _
STR$(EL) + _
" ERR=" + _
STR$(EC) : _
IF PRINTER THEN _
CALL PRINTIT(A$) _
ELSE CALL LPRNT(A$,1)
IF EL = 20126 AND EC = 53 THEN _
GOTO 20142
IF EL = 20242 AND EC = 62 THEN _
CALL UPDTCALR (FILESEC.FILE$ + " bad format!",2) : _
GOTO 20247
IF EL = 20262 THEN _
A$ = "<Download aborted>" : _
DOWNLOAD.COMPLETED = FALSE : _
GOTO 20390
IF EL = 20452 AND EC = 53 THEN _
GOTO 20451
IF EL = 20560 AND EC = 67 THEN _
GOTO 20451
IF EL = 20560 AND EC = 70 THEN _
IF VAL(FREE.SPACE$) > 1999 THEN _
GOTO 20610 _
ELSE CALL QTPUT1 ("No room for uploads. Try tomorrow.") : _
GOTO 21700
IF EL = 20620 THEN _
GOTO 20670
IF EL = 20650 THEN _
GOTO 20670
IF EL = 20736 AND EC = 53 THEN _
GOTO 21700
IF EL = 20900 AND EC = 75 THEN _
GOTO 21230
IF EL = 20900 AND EC = 70 THEN _
CALL QTPUT1 ("No room for uploads. Try tomorrow.") : _
GOTO 21230
IF EL = 21131 OR EL = 21220 THEN _
EC = 0 : _
GOTO 21230
IF EL = 21480 THEN _
CALL LOGERROR : _
IF EC = 57 THEN _
CALL QTPUT1 ("Error reading file. Aborting download") : _
DOWNLOAD.COMPLETED = FALSE : _
GOTO 21230
21910 CALL LOGERROR
CALL QTPUT1 (CALLERS.RECORD$)
FILESYS.PARAMETER = 3
RETURN
21920 ' EXIT RBBS-PC FILE SUBSYSTEM
END SUB
' $SUBTITLE: 'GETCOLOR - subroutine to see if user wants color'
' $PAGE
'
SUB GETCOLOR STATIC
'******************************************************************************
'* Find out if user wants COLOR before getting name *
'* *
'* The color values are as follows *
'* CX$(1)= red CX$(2) = GREEN CX$(3) = YELLOW CX$(4) = BLUE *
'* CX$(5)= MAGENTA CX$(6) = CYAN CX$(7) = WHITE CX$(8)= BRT.WHITE *
'* *
'******************************************************************************
'
21935 'CALL SKIPLINE(2)
'A$ = CHR$(7)+"Do you want IBM Color (Y/[N]) "
'TURBO.KEY = T.KEY
'CALL TGET
'IF Q = 0 THEN_
' GOTO 21940
'IF NOT YES THEN GOTO 21940
IF GR < 2 then GOTO 21940
CX$(1) = CHR$(27) + "[01;31;40m": CX$(2) = CHR$(27) + "[01;32;40m"
CX$(3) = CHR$(27) + "[01;33;40m": CX$(4) = CHR$(27) + "[01;34;40m"
CX$(5) = CHR$(27) + "[01;35;40m": CX$(6) = CHR$(27) + "[01;36;40m"
CX$(7) = CHR$(27) + "[01;37;40m": CX$(8) = CHR$(27) + "[01;37;40m"
EXIT SUB
'
'******************************************************************************
'* Turn Off Color if User does Not want it *
'******************************************************************************
'
21940 '
CX$(1) = "": CX$(2) = "": CX$(3) = "": CX$(4) = "": CX$(5) = ""
CX$(6) = "": CX$(7) = "": CX$(8) = ""
END SUB
'******************** INSERTED AUTO.LOGOFF here ******************
'
' $SUBTITLE: 'AUTOLOGOFF - Subroutine to to log off after transfer'
' $PAGE
'
SUB AUTOLOGOFF STATIC
AUTO.END = 0
IF GET.EXT.DESC = TRUE THEN _
EXIT SUB
SUBROUTINE.PARAMETER = 1
A$ = CHR$(7)+CX$(2)+"Auto-"+_
CX$(5)+"LogOff"+CX$(2)+" after the transfer"+_
CX$(3)+" ?(Y/[N]) "+CX$(7)+CHR$(7)
CALL QTPUT(A$,0)
A$=""
TURBO.KEY = -TURBO.KEY.USER
CALL TGET
IF NOT YES THEN _
CALL SKIPLINE (1) : _
EXIT SUB
AUTO.END = 1
CALL SKIPLINE (1)
END SUB
63100 ' $SUBTITLE: 'DOORRTN - Subroutine to process requests from a door'
' $PAGE
'
' NAME -- DOORRTN
'
' INPUTS -- PARAMETER MEANING
' DOUTx.DEF File of requests
'
' OUTPUTS -- USER.SECURITY.LEVEL Revised Security Level
'
' PURPOSE -- To give Doors a stable way to make requests
' to the host.
'
SUB DOORRTN STATIC
IF PRIVATE.DOOR OR NOT EXIT.TO.DOORS THEN _
EXIT SUB
FILE.NAME$ = "DOUT" + NODE.ID$ + ".DEF"
CALL FINDIT (FILE.NAME$)
IF NOT OK THEN _
EXIT SUB
63105 IF EOF(2) THEN _
GOTO 63195
CALL READPARMS (A$(),2,1)
IF EC > 0 THEN _
GOTO 63115
IF LEN(A$(1)) < 2 THEN _
EXIT SUB
B$ = LEFT$(A$(1),2) + ","
X = INSTR("SL,UR,",B$)
IF X = 0 THEN _
GOTO 63105
X = X\3 + 1
ON X GOTO 63110,63115
GOTO 63105
63110 X$ = LEFT$(A$(2),1) ' SL = Security Level
CALL CHECKINT (A$(2))
IF EC > 0 THEN _
GOTO 63105
IF X$ = "+" OR X$ = "-" THEN _
A = USER.SECURITY.LEVEL + TESTED.INTEGER.VALUE _
ELSE A = TESTED.INTEGER.VALUE
IF A < SYSOP.SECURITY.LEVEL THEN _
ADJUSTED.SECURITY = (A <> USER.SECURITY.LEVEL) : _
IF ADJUSTED.SECURITY THEN _
USER.SECURITY.LEVEL = A : _
MID$(USER.RECORD$,47,2) = MKI$(A) : _
CALL QTPUT1 ("Security changed to" + STR$(A)) : _
CALL UPDTCALR ("Door reset security to "+STR$(A),2)
GOTO 63105
63115 IF LEN(A$(1)) < 7 THEN _
GOTO 63105
IF MID$(A$(1),3,1) <> "(" THEN _
GOTO 63105
X = INSTR(4,A$(1),":")
IF X < 1 THEN _
GOTO 63105
CALL CHECKINT (MID$(A$(1),4,X-4))
IF EC > 0 THEN _
GOTO 63105
IF TESTED.INTEGER.VALUE > 128 OR TESTED.INTEGER.VALUE < 1 THEN _
GOTO 63105
A = TESTED.INTEGER.VALUE
CALL CHECKINT (MID$(A$(1),X+1))
IF EC > 0 OR TESTED.INTEGER.VALUE < 1 OR TESTED.INTEGER.VALUE > 128 THEN _
GOTO 63105
MID$(USER.RECORD$,A,TESTED.INTEGER.VALUE) = LEFT$(A$(2) + _
SPACE$(TESTED.INTEGER.VALUE),TESTED.INTEGER.VALUE)
CALL UPDTCALR ("Door set UR"+STR$(A)+":"+STR$(TESTED.INTEGER.VALUE)+" to <"+A$(2)+">",2)
GOTO 63105
63195 CALL KILLWORK (FILE.NAME$)
EC = 0
END SUB
63200 ' $SUBTITLE: 'WILDCARD -- Matches string to a pattern'
' $PAGE
' NAME -- WILDCARD
'
' INPUTS -- PARAMETER MEANING
' PATTERN$ PATTERN TO CHECK
' STRNG$ STRING TO FIE
'
' OUTPUTS -- OK TRUE IF MATCH FOUND
' FALSE IF NO MATCH WAS FOUND
'
' PURPOSE Determine whether a string is an instance in a pattern
' supported patterns are only "?" which requires a
' character but can be any, and "*" which matches any-
' thing, including a null string. Anything else in a
' sting must be an exact match. Supports reverse
' wildcards.
'
'
SUB WILDCARD (PATTERN$,STRNG$) STATIC
63285 OK = TRUE
PATPOS = 0
STRPOS = 0
INC = 1
KT = 0
P = LEN(PATTERN$)
L = LEN(STRNG$)
63286 PATPOS = PATPOS + INC
STRPOS = STRPOS + INC
KT = KT + 1
IF KT > L THEN _
GOTO 63288
B$ = MID$(PATTERN$,PATPOS,1)
IF B$ = "*" THEN _
GOTO 63289
63287 IF B$ <> "?" AND MID$(STRNG$,STRPOS,1) <> B$ THEN _
OK = FALSE : _
EXIT SUB
GOTO 63286
63288 IF PATPOS >= LEN(PATTERN$) OR PATPOS < 1 THEN _
EXIT SUB
IF MID$(PATTERN$,PATPOS,1) <> "*" THEN _
OK = FALSE : _
EXIT SUB
63289 IF PATPOS <> P THEN _ ' Reverse search
INC = -1 : _
P = PATPOS : _
PATPOS = LEN(PATTERN$) + 1 : _
STRPOS = LEN(STRNG$) + 1 : _
KT = 0 : _
GOTO 63286
END SUB
63300 ' $SUBTITLE: 'BRKFNAME - sub to split file name into components'
' $PAGE
'
' NAME -- BRKFNAME
'
' INPUTS -- PARAMETER MEANING
' FILENAME$ FULL NAME OF FILE
' FOR.JOINING TRUE IF WANT PARTS FORMATTED FOR
' FORMING FILE NAMES
' OUTPUTS -- DRVPATH$ DRIVE AND PATH
' PREFIX$ PREFIX OF FILE NAME
' EXTENSION$ EXTENSION OF FILE NAME
'
' (E.G. "C:\RBBS\ARCE.COM" HAS "C:\RBBS" AS DRIVE AND PATH,
' "ARCE" AS PREFIX OF THE FILE NAME, AND
' "COM" AS THE EXTENSION OF THE FILE NAME.
'
' JOINED FORMAT IS C:\RBBS\,ARCE,.COM
'
' PURPOSE -- To break a file name into its component parts
' of drive/path, prefix, and extension
'
'
SUB BRKFNAME (FILENAME$,DRVPATH$,PREFIX$,EXTENSION$,FOR.JOINING) STATIC
CALL ALLCAPS (FILENAME$)
DRVPATH$ = ""
PREFIX$ = ""
EXTENSION$ = ""
CALL TRIMTRAIL (FILENAME$,"\")
L = LEN(FILENAME$)
IF L < 1 THEN _
EXIT SUB
CALL FINDLAST (FILENAME$,"\",X,Y)
IF X < 1 THEN _
IF MID$(FILENAME$,2,1) = ":" THEN _
DRVPATH$ = LEFT$(FILENAME$,1) : _
S = 3 _
ELSE S = 1 _
ELSE DRVPATH$ = LEFT$(FILENAME$,X-1) : _
S = X + 1 : _
IF Y = 1 THEN _ ' KG061201
DRVPATH$ = DRVPATH$ + "\" ' KG061201
X = INSTR(FILENAME$ + ".",".")
IF X < L THEN _
EXTENSION$ = MID$(FILENAME$,X + 1,3)
IF S <= L THEN _
IF X >= S THEN _
PREFIX$ = MID$(FILENAME$,S,X - S)
IF NOT FOR.JOINING THEN _
EXIT SUB
IF LEN(DRVPATH$) = 1 THEN _
IF DRVPATH$ <> "\" THEN _ ' KG061201
DRVPATH$ = DRVPATH$ + _ ' KG061201
":" ' KG061201
IF INSTR(DRVPATH$,"\") > 0 AND RIGHT$(DRVPATH$,1) <> "\" THEN _ ' KG061201
DRVPATH$ = DRVPATH$ + _
"\"
IF LEN(EXTENSION$) > 0 THEN _
EXTENSION$ = "." + _
EXTENSION$
END SUB
63310 ' $SUBTITLE: 'RESTORECOM - sub to restore comm port'
' $PAGE
'
' NAME -- RESTORECOM
'
' INPUTS -- none
'
' OUTPUTS -- none
'
' PURPOSE -- To restore communications port after an external
' program may have left it in altered state
'
SUB RESTORECOM STATIC
PARITY$ = MID$(",N,8,1,E,7,1",7 + 6 * EIGHT.BIT,6)
IF LOCAL.USER THEN _
EXIT SUB
CALL SETBAUD ' KG052102
IF NOT FOSSIL THEN _ ' KG052102
CALL OPENCOM(TALK.TO.MODEM.AT$,PARITY$)
END SUB
63320 ' $SUBTITLE: 'SHELLEXIT - sub to shell out from RBBS'
' $PAGE
'
' NAME -- SHELLEXIT
'
' INPUTS -- SHELL.TEM$ String to invoke shell with
'
' OUTPUTS -- none
'
' PURPOSE -- Delay so that strings can finish printing. Restore comm
' port on return
'
SUB SHELLEXIT (SHELL.TEM$) STATIC
CALL DELAYIT (8 + BPS)
IF FOSSIL THEN _
CALL FOSEXIT(COMPORT%) _
ELSE CLOSE 3 : _
OUT MODEM.CONTROL.REGISTER,INP(MODEM.CONTROL.REGISTER) OR 1
CLOSE 2
CALL METAGSR (SHELL.TEM$,FALSE)
SHELL SHELL.TEM$
IF FOSSIL THEN _
CALL FOSINIT(COMPORT%,RESULT%) : _
IF RESULT% = -1 THEN _
CALL PSCRN("ERROR INITIALIZING FOSSIL AFTER EXTERNAL PROTOCOL") : _
SYSTEM
CALL DELAYIT (2)
CALL RESTORECOM
END SUB
63330 ' $SUBTITLE: 'READMACRO - sub to read macro'
' $PAGE
'
' NAME -- READMACRO
'
' INPUTS -- PARAMETER MEANING
'
' OUTPUTS -- A$ LINE TO PROCESS IN MACRO
' MACRO.ACTIVE FLAG WHETHER IN A MACRO
'
' PURPOSE -- Reads in a line from macro file (#6) and processes
' macro commands, which are:
' *0 - display what follows, no carriage return
' *1 - display what follows with carriage return
' *B - display block that follows
' *F - display File
' WT - wait specified # of seconds
' >> - append following block to specified file
' ST - stack following (with carriage return)
' ON - define case
' == - case value that applies to following block
' M! - execute following macro
' M@ - abort macro processing
' EY - Echo on (yes)
' EN - Echo off (no)
' /* - comment line skipped in processing
' TK - Turbo key on (if user preference)
' << - Read from file into a form
'
SUB READMACRO STATIC
IF MACRO.TEMPLATE$ <> "" THEN _
GOTO 63392
IF DISTANT.TGET = 2 THEN _
GOTO 63349
63336 GOSUB 63395
IF NOT MACRO.ACTIVE THEN _
MACRO.ECHO = TRUE : _
EXIT SUB
IF LEN(A$) < 3 THEN _
GOTO 63398
X$ = RIGHT$(A$,LEN(A$)-3)
IF COMPARE.VAR > 0 THEN _
IF NOT CASE.EXECUTE THEN _
IF LEFT$(A$,3) = SMART.TEXT$+"==" THEN _
GOTO 63370 _
ELSE IF LEFT$(A$,7) = "{END ON" THEN _
COMPARE.VAR = 0 : _
GOTO 63336 _
ELSE GOTO 63336
IF LEFT$(A$,1) <> SMART.TEXT$ THEN _
GOTO 63398
CALL CHECKINT (MID$(A$,2))
IF EC > 0 THEN _
GOTO 63398
IF TESTED.INTEGER.VALUE > 0 AND TESTED.INTEGER.VALUE <= MAX.WORK.VAR THEN _
A$ = X$ : _ ' Macro command ask
SUBROUTINE.PARAMETER = 4 : _
CALL TPUT : _
A$ = "" : _
B$ = "" :_
FORCE.KEYBOARD = TRUE : _
MACRO.SAVE = TESTED.INTEGER.VALUE : _
LINES.PRINTED = 1 : _
NON.STOP = (PAGE.LENGTH < 1) : _ ' KG072603
EXIT SUB
ON (1+INSTR("*0*1*B*FWT>>STON==M!M@EYEN/*TK<<",MID$(A$,2,2)))\2 GOTO _
63345, _ ' Display with no Carriage Return
63347, _ ' Display with Carriage Return
63340, _ ' Display Block
63348, _ ' Display File
63343, _ ' Wait # of seconds
63350, _ ' Append to file
63355, _ ' Stack
63360, _ ' Case
63370, _ ' Case Comparison
63375, _ ' Macro execute
63380, _ ' Macro Abort
63383, _ ' Macro Echo on
63385, _ ' Macro Echo off
63336, _ ' Macro Comment
63387, _ ' Turbo Key allowed
63390 ' Form read
GOTO 63398
63338 A$ = X$
63339 SUBROUTINE.PARAMETER = 4 ' KG062803
CALL TPUT
RETURN
63340 X$ = SMART.TEXT$ + "END" ' Print Block
GOSUB 63395
WHILE MACRO.ACTIVE AND LEFT$(A$,4) <> X$
GOSUB 63339
CALL SKIPLINE (1)
GOSUB 63395
WEND
GOTO 63336
63343 CALL CHECKINT (X$) ' Delay
IF EC = 0 THEN _
CALL DELAYIT (TESTED.INTEGER.VALUE)
GOTO 63336
63345 GOSUB 63338 ' Print Line
GOTO 63336
63347 GOSUB 63338
CALL SKIPLINE (1)
GOTO 63336
63348 CALL TRIM (X$) ' Print File
CALL FINDITX (X$,7) ' KG061001
IF NOT OK THEN _
GOTO 63336
LINES.PRINTED = 1
NO = FALSE ' KG071902
NON.STOP = (NON.STOP OR PAGE.LENGTH < 1) ' KG060401
63349 WHILE (NOT EOF(7) AND (NOT NO) AND (NON.STOP OR (LINES.PRINTED < PAGE.LENGTH)) AND (SUBROUTINE.PARAMETER > -1)) ' KG071904
CALL READDIR (7,1) ' KG061001
GOSUB 63396 ' KG060401
SUBROUTINE.PARAMETER = 5
CALL TPUT
WEND
DISTANT.TGET = 0
IF SUBROUTINE.PARAMETER < 0 THEN _
EXIT SUB
IF EOF(7) OR NO THEN _ ' KG061001
CLOSE 7 : _ ' KG061001
NO = FALSE : _ ' KG061001
GOTO 63336
DISTANT.TGET = 2
CALL PAUSEEXIT
EXIT SUB
63350 EN$ = X$ ' Append to file
X = INSTR(EN$," /FL")
OVERSTRIKE = (X > 0)
IF OVERSTRIKE THEN _
EN$ = LEFT$(EN$,X-1) + RIGHT$(EN$,LEN(EN$)-X-3)
CALL TRIM (EN$)
CALL LOCKAPPND
IF EC > 0 THEN _
GOTO 63352
GOSUB 63395
X$ = SMART.TEXT$ + "END"
WHILE MACRO.ACTIVE AND LEFT$(A$,4) <> X$ ' KG062803
CALL PRNTWRKA (A$)
GOSUB 63395
WEND
63352 CALL UNLKAPPND
OVERSTRIKE = FALSE
GOTO 63336
63355 COMMPORT.STACK$ = COMMPORT.STACK$ + X$ + CARRIAGE.RETURN$ ' STack
GOTO 63336
63360 COMPARE.VAR = VAL(X$)
CALL ALLCAPS (X$) ' KG062901
IF COMPARE.VAR < 1 OR COMPARE.VAR > MAX.WORK.VAR THEN _
COMPARE.VAR = 0
GOTO 63336
63370 IF COMPARE.VAR = 0 THEN _ ' Compare Case
GOTO 63336
DF$ = GSR.ARA$(COMPARE.VAR)
CALL ALLCAPS (DF$)
CASE.EXECUTE = (X$ = DF$)
GOTO 63336
63375 CALL TRIM (X$) ' Execute Macro
CALL CHKMACRO (X$,X)
GOTO 63336
63380 MACRO.ACTIVE = FALSE ' Abort Macro
GOTO 63398
63383 MACRO.ECHO = TRUE
GOTO 63336
63385 MACRO.ECHO = FALSE
GOTO 63336
63387 TURBO.KEY = -TURBO.KEY.USER 'TK Turbo Key
GOTO 63336
63390 B$ = A$
B$(5) = ""
B$(6) = ""
Q = 1
STORE.PARSE.AT = 1 ' KG083101
CALL PARSEIT
IF Q < 4 THEN _
GOTO 63336
X$ = SMART.TEXT$ + "END"
GOSUB 63397 ' KG081006
MACRO.TEMPLATE$ = ""
WHILE MACRO.ACTIVE AND LEFT$(A$,4) <> X$
MACRO.TEMPLATE$ = MACRO.TEMPLATE$ + A$ + CRLF$
GOSUB 63397 ' KG080302
WEND
X = VAL(B$(4))
VAR.LEN = (B$(3) <> "/F")
CALL FINDIT (B$(2))
IF (X < 1) OR (NOT OK) OR (VAR.LEN AND X > MAX.WORK.VAR) THEN _
MACRO.TEMPLATE$ = "" : _
GOTO 63336
63392 CALL FORMREAD (MACRO.TEMPLATE$,B$(2),NOT VAR.LEN,X,(B$(5) = "/FL"),(B$(6) = "/1"))
IF MACRO.TEMPLATE$ <> "" THEN _
EXIT SUB _
ELSE GOTO 63336
63395 GOSUB 63397 ' KG080302
GOSUB 63396 ' KG080302
RETURN ' KG080302
63396 CALL SMARTTXT (A$,FALSE, OVERSTRIKE)
CALL METAGSR (A$,OVERSTRIKE)
RETURN
63397 IF EOF(6) THEN _ ' Read next line in macro ' KG080302
MACRO.ACTIVE = FALSE _
ELSE CALL READDIR (6,1) : _ ' KG080302
MACRO.ACTIVE = (EC = 0)
RETURN
63398 END SUB ' Not Macro command - pass to normal processing
63400 ' $SUBTITLE: 'LOCKAPPND - prepares for file append'
' $PAGE
'
' NAME -- LOCKAPPND
'
' INPUTS -- EN$ Name of file to append to
'
' OUTPUTS -- none
'
' PURPOSE -- Locks and opens file to append to
'
SUB LOCKAPPND STATIC
BX = &H4
SUBROUTINE.PARAMETER = 9
CALL FILELOCK
EC = 0
CALL OPENWRKA (EN$)
END SUB
63410 ' $SUBTITLE: 'UNLKAPPND - cleans up after file append'
' $PAGE
'
' NAME -- UNLKAPPND
'
' INPUTS -- none
'
' OUTPUTS -- none
'
' PURPOSE -- Unlocks and close file appending to
'
SUB UNLKAPPND STATIC
BX = &H4
SUBROUTINE.PARAMETER = 10
CALL FILELOCK
CLOSE 2
END SUB
63420 ' $SUBTITLE: 'FORMREAD - Reads from a file into a form'
' $PAGE
'
' NAME -- FORMREAD
'
' INPUTS -- TEMPLATE$ Display formvoke shell with
' FILNAME$ Data file to get values from
' FIXED.LENGTH Whether file is fixed length
' DATA.VAR # bytes data if fixed length; # fields
' if variable length
' OVERSTRIKE Whether typeover into form or insert
' REC.PAUSE Whether pause after every record displayed
' otherwise when screen fills
' OUTPUTS -- (displays data base records)
'
' PURPOSE -- Allows field oriented data base data to be displayed
' in a human readable format by substituting field
' data into template or form
'
SUB FORMREAD (TEMPLATE$,FILNAME$,FIXED.LENGTH,DATA.VAR,OVERSTRIKE,REC.PAUSE) STATIC
63422 IF EOF(2) OR NO OR (EC > 0) OR (SUBROUTINE.PARAMETER < 0) THEN _
TEMPLATE$ = "" : _
EXIT SUB
IF FIXED.LENGTH THEN _
CALL READDIR (2,1) : _
GSR.ARA$(1) = A$ _
ELSE CALL READPARMS (GSR.ARA$(),DATA.VAR,1)
X$ = TEMPLATE$
CALL SMARTTXT (X$,TRUE,OVERSTRIKE)
CALL METAGSR (X$,OVERSTRIKE)
CALL BUFASUNIT (X$)
IF REC.PAUSE OR (PAGE.LENGTH > 0 AND (LINES.PRINTED >= PAGE.LENGTH-1)) THEN _
CALL PAUSEEXIT : _
EXIT SUB
GOTO 63422
END SUB
63440 ' $SUBTITLE: 'BUFASUNIT - prints string with no pauses'
' $PAGE
'
' NAME -- BUFASUNIT
'
' INPUTS -- STRNG$ String to print
'
' OUTPUTS -- none
'
' PURPOSE -- Prints string with embedded carriage returns.
' Will never pause. Used to print when can't call TGET
'
SUB BUFASUNIT (STRNG$) STATIC
L = LEN(STRNG$)
IF L < 1 THEN _
EXIT SUB
START.BYTE = 1
63450 CRAT = INSTR(START.BYTE,STRNG$,CARRIAGE.RETURN$)
IF CRAT > 0 AND CRAT < L THEN _
CR.FOUND = (MID$(STRNG$,CRAT + 1,1) = LINE.FEED$) _
ELSE CR.FOUND = FALSE
EOL.LEN = -2 * CR.FOUND
IF CR.FOUND THEN _
EOD = CRAT _
ELSE EOD = L + 1
NUM.BYTES = EOD - START.BYTE
A$ = MID$(STRNG$,START.BYTE,NUM.BYTES)
SUBROUTINE.PARAMETER = 4
CALL TPUT
CALL SKIPLINE (-(CR.FOUND))
IF RET THEN _
EXIT SUB
START.BYTE = EOD + EOL.LEN
IF START.BYTE <= L THEN _
GOTO 63450
END SUB
63460 SUB MACROEXE (STRNG$) STATIC
CALL TRIM (STRNG$)
CALL FINDIT (STRNG$)
IF NOT OK THEN _
EXIT SUB
COMMPORT.STACK$ = COMMPORT.STACK$ + STRNG$ + CARRIAGE.RETURN$
CALL FDMACEXE
END SUB
63462 SUB FDMACEXE STATIC
A$ = ""
MACRO.ECHO = FALSE
SUBROUTINE.PARAMETER = 4
CALL TGET
END SUB
63465 SUB PAUSEEXIT STATIC
' CALL SKIPLINE (1)
SUBROUTINE.PARAMETER = 4
TURBO.KEY = -TURBO.KEY.USER
A$ = MORE.PROMPT$ + ">" + MID$("? ! ",2*TURBO.KEY+1,2)
FORCE.KEYBOARD = TRUE
NO.ADVANCE = TRUE
CALL TPUT
LINES.PRINTED = 0
B$ = "" ' KG060401
END SUB
63470 ' $SUBTITLE: 'CALLOPT - sub to set prompts based on user security'
' $PAGE
'
' NAME -- CALLOPT
'
' INPUTS -- PARAMETER MEANING
' BEG.MAIN POSITION START OF MAIN CMDS
' BEG.FILE POSITION START OF FILE CMDS
' BEG.UTIL POSITION START OF UTIL CMDS
' BEG.LIBRARY POSITION START OF LIBRARY CMDS
'
' OUTPUTS -- PRESENT.OPTS$ DISPLAY WHAT USER CAN DO (1st)
' CALLERS.OPTS$ DISPLAY WHAT USER CAN DO (2nd)
' MAIN.OPTS$ MAIN OPTS USER CAN DO
' FILE.OPTS$ FILE OPTS USER CAN DO
' UTIL.OPTS$ UTIL OPTS USER CAN DO
' LIBRARY.OPTS$ LIBRARY OPTS USER CAN DO
'
' PURPOSE -- Sets command line display of what user can do by
' section and display of what all user can do
'
SUB CALLOPT STATIC
FIRST = BEG.MAIN
LAST = BEG.FILE - 1
CALL SETOPTS (MAIN.OPTS$,INVALID.MAIN.OPTS$,FIRST,LAST)
FIRST = BEG.FILE
LAST = BEG.UTIL - 1
CALL SETOPTS (FILE.OPTS$,INVALID.FILE.OPTS$,FIRST,LAST)
FIRST = BEG.UTIL
LAST = BEG.LIBRARY - 1
CALL SETOPTS (UTIL.OPTS$,INVALID.UTIL.OPTS$,FIRST,LAST)
FIRST = BEG.LIBRARY
LAST = BEG.LIBRARY + 6
CALL SETOPTS (LIBRARY.OPTS$,INVALID.LIBRARY.OPTS$,FIRST,LAST)
FIRST = 50
LAST = 56
CALL SETOPTS (SYS.OPTS$,INVALID.SYS.OPTS$,FIRST,LAST)
FIRST = 46
LAST = 49
CALL SETOPTS (GLOBAL.OPTS$,INVALID.GLOBAL.OPTS$,FIRST,LAST)
IF LEN(SYS.OPTS$) > 0 THEN _
SYSTEM.OPTS$ = "Sysop: " + _
SYS.OPTS$
MAIN.OPTS$ = GLOBAL.OPTS$ + _
MAIN.OPTS$
FILE.OPTS$ = GLOBAL.OPTS$ + _
FILE.OPTS$
UTIL.OPTS$ = GLOBAL.OPTS$ + _
UTIL.OPTS$
LIBRARY.OPTS$ = GLOBAL.OPTS$ + _
LIBRARY.OPTS$
CALL SRTSTRNG (SYS.OPTS$)
CALL SRTSTRNG (MAIN.OPTS$)
MAIN.OPTS$ = MAIN.OPTS$ + _
SYS.OPTS$
CALL SRTSTRNG (FILE.OPTS$)
CALL SRTSTRNG (UTIL.OPTS$)
CALL SRTSTRNG (LIBRARY.OPTS$)
CALL INSCOMMA (MAIN.OPTS$)
CALL INSCOMMA (FILE.OPTS$)
CALL INSCOMMA (UTIL.OPTS$)
CALL INSCOMMA (LIBRARY.OPTS$)
DIR.PROMPT$ = "What directory(s) (" + _
MID$("U)pload,A)ll,L)ist,E)xtended +/-, [Q]uit)",8 * (USER.SECURITY.LEVEL => MIN.SEC.TO.VIEW) + 9)
QUIT.PROMPT.EXPERT$ = "QUIT C,S, or to F,[M],U,@"
QUIT.PROMPT.NOVICE$ = "QUIT C)onference, S)ession or to section " + _
"F)ile, [M]ain, U)til or @)Library"
QUIT.LIST$ = "FMUS@C"
IF USER.SECURITY.LEVEL < OPT.SEC(18) THEN _
QUIT.PROMPT.EXPERT$ = LEFT$(QUIT.PROMPT.EXPERT$,23) : _
QUIT.PROMPT.NOVICE$ = LEFT$(QUIT.PROMPT.NOVICE$,61) : _
MID$(QUIT.LIST$,5) = " "
IF USER.SECURITY.LEVEL < OPT.SEC(15) THEN _
QUIT.PROMPT.EXPERT$ = LEFT$(QUIT.PROMPT.EXPERT$,22) + _
MID$(QUIT.PROMPT.EXPERT$,25) : _
QUIT.PROMPT.NOVICE$ = LEFT$(QUIT.PROMPT.NOVICE$,56) + _
MID$(QUIT.PROMPT.NOVICE$,63) : _
MID$(QUIT.LIST$,3,1) = " "
IF USER.SECURITY.LEVEL < OPT.SEC(6) THEN _
QUIT.PROMPT.EXPERT$ = LEFT$(QUIT.PROMPT.EXPERT$,16) + _
MID$(QUIT.PROMPT.EXPERT$,19) : _
QUIT.PROMPT.NOVICE$ = LEFT$(QUIT.PROMPT.NOVICE$,41) + _
MID$(QUIT.PROMPT.NOVICE$,49) : _
MID$(QUIT.LIST$,1,1) = " "
CALL SETSECT
END SUB
63480 ' $SUBTITLE: 'NOPATH - detects whether string has path'
' $PAGE
'
' NAME -- NOPATH
'
' INPUTS -- STRNG$ String to check
'
' OUTPUTS -- HAS.NONE True if has no path
'
' PURPOSE -- Detects whether have path. Used when shouldn't
' be any
'
SUB NOPATH (STRNG$,HAS.PATH) STATIC ' KG060801
CALL BRKFNAME (STRNG$,DRVPATH$,PREFX$,EXT$,FALSE) ' KG060801
HAS.PATH = (DRVPATH$ <> "") ' KG060801
END SUB ' KG060801
63490 ' $SUBTITLE: 'FINDIT - Determine whether file exists'
' $PAGE
'
' NAME -- FINDIT
'
' INPUTS -- FILNAME$ File name to check
'
' OUTPUTS -- OK True if file exists. Opened as #2 if does
'
' PURPOSE -- Determine whether file exists and open as standard work
' file if it does (#2)
'
SUB FINDIT (FILNAME$) STATIC ' KG061001
CALL FINDITX (FILNAME$,2) ' KG061001
END SUB ' KG061001
63495 ' $SUBTITLE: 'TIMEBACK - Give time back to the user' ' KG082701
' $PAGE
'
' NAME -- TIMEBACK
'
' INPUTS -- INDEX = 1 Set start of time (begin give back)
' = 2 Give back time from defined start
'
' OUTPUTS -- TIME.CREDIT! Number of seconds to credit with
' SECONDS.PER.SESSION! Number of seconds in current session
'
' PURPOSE -- Give time back to the user (e.g. sysop initiated chat)
'
SUB TIMEBACK (INDEX) STATIC ' KG082701
IF INDEX = 1 THEN _ ' KG082701
CALL TIMEREMAIN (TIME.REMAINING!) : _ ' KG082701
Q! = TCA! : _ ' KG082701
EXIT SUB ' KG082701
CALL TIMEREMAIN (TIME.REMAINING!) ' KG082701
X! = (TCA! - Q!) ' KG082701
TIME.CREDITS! = TIME.CREDITS! + X! ' KG082701
SECONDS.PER.SESSION! = SECONDS.PER.SESSION! + X! ' KG082701
END SUB ' KG082701
63500 ' $SUBTITLE: 'CSPUSHPOP - Save/restore command stack' ' KG082702
' $PAGE
'
' NAME -- CSPUSHPOP
'
' INPUTS -- INDEX = 1 Save command stack
' = 2 Restore command stack
' ANS.INDEX
' LAST.INDEX
' B$()
'
' OUTPUTS -- B$() Stacked commands
' ANS.INDEX
' LAST.INDEX
'
' PURPOSE -- Save restore a command stack list when need to input
' another list in middle of previous list processing
'
SUB CSPUSHPOP (INDEX) STATIC ' KG082702
IF INDEX = 1 THEN _ ' KG082702
ORIG.LAST.INDEX = LAST.INDEX : _ ' save ' KG082702
ORIG.INDEX = ANS.INDEX : _ ' KG082702
FOR I = 1 TO ORIG.LAST.INDEX : _ ' KG082702
A$(I) = B$(I) : _ ' KG082702
NEXT : _ ' KG082702
EXIT SUB ' KG082702
LAST.INDEX = ORIG.LAST.INDEX ' restore ' KG082702
ANS.INDEX = ORIG.INDEX ' KG082702
FOR I = 1 TO ORIG.LAST.INDEX ' KG082702
B$(I) = A$(I) ' KG082702
NEXT ' KG082702
END SUB ' KG082702